llvm-pretty-bc-parser 0.4.0.0 → 0.4.1.0
raw patch · 79 files changed
+6289/−1981 lines, 79 filesdep +HUnitdep +QuickCheckdep +binarydep −abstract-pardep −cerealdep −monad-pardep ~basedep ~bytestringdep ~containersnew-component:exe:regression-testnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, QuickCheck, binary, exceptions, foldl, generic-random, lens, mtl, optparse-applicative, pretty-show, prettyprinter, string-interpolate, syb, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, tasty-sugar, terminal-size, text, turtle, uniplate, utf8-string, versions
Dependencies removed: abstract-par, cereal, monad-par
Dependency ranges changed: base, bytestring, containers, llvm-pretty, transformers
API changes (from Hackage documentation)
+ Data.LLVM.Internal: PartialUnnamedMd :: Int -> PValMd -> Bool -> PartialUnnamedMd
+ Data.LLVM.Internal: [pumDistinct] :: PartialUnnamedMd -> Bool
+ Data.LLVM.Internal: [pumIndex] :: PartialUnnamedMd -> Int
+ Data.LLVM.Internal: [pumValues] :: PartialUnnamedMd -> PValMd
+ Data.LLVM.Internal: data PartialUnnamedMd
+ Data.LLVM.Internal: dedupMetadata :: Seq PartialUnnamedMd -> Seq PartialUnnamedMd
+ Data.LLVM.Internal: finalizePValMd :: PValMd -> Finalize ValMd
+ Data.LLVM.Internal: finalizePartialUnnamedMd :: PartialUnnamedMd -> Finalize UnnamedMd
+ Data.LLVM.Internal: parseMetadataBlock :: Int -> ValueTable -> [Entry] -> Parse ParsedMetadata
+ Data.LLVM.Internal: parseMetadataKindEntry :: Record -> Parse ()
+ Data.LLVM.Internal: type InstrMdAttachments = Map Int [(KindMd, PValMd)]
+ Data.LLVM.Internal: type PFnMdAttachments = Map PKindMd PValMd
+ Data.LLVM.Internal: type PGlobalAttachments = Map Symbol (Map KindMd PValMd)
+ Data.LLVM.Internal: type PKindMd = Int
Files
- CHANGELOG.md +20/−0
- README.md +70/−0
- disasm-test/Main.hs +834/−138
- disasm-test/tests/T189.ll +29/−0
- disasm-test/tests/T266-constant-icmp.ll +7/−0
- disasm-test/tests/T266-constant-icmp.pre-llvm15.ll +7/−0
- disasm-test/tests/alloca.ll +0/−10
- disasm-test/tests/atomicrmw.ll +4/−0
- disasm-test/tests/btf-tag-dicompositetype.ll +10/−0
- disasm-test/tests/btf-tag-dicompositetype.pre-llvm14.ll +1/−0
- disasm-test/tests/btf-tag-diderivedtype.ll +10/−0
- disasm-test/tests/btf-tag-diderivedtype.pre-llvm14.ll +1/−0
- disasm-test/tests/btf-tag-diglobalvariable.ll +15/−0
- disasm-test/tests/btf-tag-diglobalvariable.pre-llvm14.ll +1/−0
- disasm-test/tests/btf-tag-dilocalvariable.ll +14/−0
- disasm-test/tests/btf-tag-dilocalvariable.pre-llvm14.ll +1/−0
- disasm-test/tests/btf-tag-disubprogram.ll +15/−0
- disasm-test/tests/btf-tag-disubprogram.pre-llvm14.ll +1/−0
- disasm-test/tests/callbr.ll +47/−0
- disasm-test/tests/callbr.pre-llvm15.ll +40/−0
- disasm-test/tests/cmpxchg.ll +73/−0
- disasm-test/tests/debug-loc.ll +0/−43
- disasm-test/tests/derivedtype.ll +52/−0
- disasm-test/tests/di-arg-list.ll +43/−0
- disasm-test/tests/di-arg-list.pre-llvm13.ll +1/−0
- disasm-test/tests/diderivedtype-address-space.at-least-llvm14.ll +4/−0
- disasm-test/tests/dilocalvariable.ll +32/−0
- disasm-test/tests/dilocalvariable.pre-llvm14.ll +1/−0
- disasm-test/tests/fcmp-fast-math.ll +23/−0
- disasm-test/tests/fneg.ll +14/−0
- disasm-test/tests/global-alias.ll +0/−10
- disasm-test/tests/global-var-extern.ll +32/−0
- disasm-test/tests/global-var.ll +13/−0
- disasm-test/tests/global.ll +0/−1
- disasm-test/tests/instrmd.ll +33/−0
- disasm-test/tests/metadata.ll +0/−10
- disasm-test/tests/opaque-atomicrmw.ll +4/−0
- disasm-test/tests/opaque-atomicrmw.pre-llvm15.ll +4/−0
- disasm-test/tests/opaque-call.ll +11/−0
- disasm-test/tests/opaque-call.pre-llvm15.ll +4/−0
- disasm-test/tests/opaque-constant-getelementptr.ll +9/−0
- disasm-test/tests/opaque-constant-getelementptr.pre-llvm15.ll +4/−0
- disasm-test/tests/opaque-getelementptr.ll +8/−0
- disasm-test/tests/opaque-getelementptr.pre-llvm15.ll +4/−0
- disasm-test/tests/p0.ll +533/−0
- disasm-test/tests/poison.ll +3/−0
- disasm-test/tests/poison.pre-llvm12.ll +1/−0
- disasm-test/tests/printf_frexpl.ll +0/−60
- disasm-test/tests/smallprog.ll +226/−0
- fuzzing/Main.hs +51/−38
- llvm-disasm/LLVMDis.hs +47/−26
- llvm-pretty-bc-parser.cabal +118/−33
- regression-test/Main.hs +242/−0
- src/Data/LLVM/BitCode/Assert.hs +115/−0
- src/Data/LLVM/BitCode/BitString.hs +144/−38
- src/Data/LLVM/BitCode/Bitstream.hs +61/−60
- src/Data/LLVM/BitCode/GetBits.hs +313/−85
- src/Data/LLVM/BitCode/IR.hs +18/−8
- src/Data/LLVM/BitCode/IR/Attrs.hs +10/−0
- src/Data/LLVM/BitCode/IR/Blocks.hs +19/−0
- src/Data/LLVM/BitCode/IR/Constants.hs +251/−93
- src/Data/LLVM/BitCode/IR/Function.hs +623/−209
- src/Data/LLVM/BitCode/IR/Globals.hs +14/−12
- src/Data/LLVM/BitCode/IR/Metadata.hs +1294/−859
- src/Data/LLVM/BitCode/IR/Module.hs +105/−55
- src/Data/LLVM/BitCode/IR/Types.hs +39/−17
- src/Data/LLVM/BitCode/IR/Values.hs +38/−44
- src/Data/LLVM/BitCode/Parse.hs +273/−112
- src/Data/LLVM/BitCode/Record.hs +44/−18
- src/Data/LLVM/CFG.hs +2/−2
- src/Data/LLVM/Internal.hs +6/−0
- unit-test/Main.hs +8/−0
- unit-test/Tests/ExpressionInstances.hs +43/−0
- unit-test/Tests/FuncDataInstances.hs +24/−0
- unit-test/Tests/Instances.hs +39/−0
- unit-test/Tests/Metadata.hs +46/−0
- unit-test/Tests/PrimInstances.hs +13/−0
- unit-test/Tests/StmtInstances.hs +15/−0
- unit-test/Tests/TripleInstances.hs +15/−0
+ CHANGELOG.md view
@@ -0,0 +1,20 @@+# Revision history for llvm-pretty-bc-parser++## 0.4.1.0 (January 2024)++* Add preliminary support for LLVM versions up through 16.+* Require building with `llvm-pretty-0.12.*`.+* Add preliminary support for parsing opaque pointers. For now,+ `llvm-pretty-bc-parser` will still fill in the types of certain instructions+ with non-opaque pointer types (e.g., the type of memory to store in a `store`+ instruction), so be wary of this if you are parsing a bitcode file that+ contains opaque pointers. See also the discussion in+ https://github.com/GaloisInc/llvm-pretty-bc-parser/issues/262.+* Improve the runtime performance of the parser.+* A variety of bugfixes. Some notable fixes include:+ * Fix a bug in which the parser would fail to parse `DIDerivedType` nodes+ produced by Apple Clang on macOS.+ * Fix a bug in which the DWARF address space field of a `DIDerivedType` node+ was parsed incorrectly.+ * Fix a bug in which constant `fcmp`/`icmp` expressions would parse their+ operands incorrectly.
+ README.md view
@@ -0,0 +1,70 @@+# llvm-pretty-bc-parser++A parser for the LLVM bitcode file format, yielding a `Module` from+[the llvm-pretty package](http://hackage.haskell.org/package/llvm-pretty).++## Compatibility++The following table shows what kinds of tests have been/are being run with which+compilers.++ - A check in the the randomized tests column indicates that such tests are+ regularly run [in Github Actions][fuzz-workflow].+ - A check in the manual tests column indicates that the parser seems to work on+ some code that was generated by this compiler.++| Compiler | Version | [Randomized tests](./fuzzing) | Manual tests | Notes |+|-----------|---------|-------------------------------|--------------|----------------------|+| `clang` | v3.4 | ✓ | | |+| | v3.5 | ✓ | | |+| | v3.6 | ✓ | | |+| | v3.7 | ✓ | | |+| | v3.8 | ✓ | ✓ | |+| | v3.9 | ✓ | | |+| | v4.0 | ✓ | | |+| | v5.0 | ✓ | | |+| | v6.0 | ✓ | ✓ | |+| | v7.0 | ✓ | | |+| | v8.0 | ✓ | | |+| | v9.0 | ✓ | | |+| | v10.0 | ✓ | | |+| | v11.0 | ✓ | | |+| | v12.0 | ✓ | | |+| | v13.0 | ✓ | | See [issues][llvm13] |+| | v14.0 | ✓ | | See [issues][llvm14] |+| | v15.0 | ✓ | | See [issues][llvm15] |+| | v16.0 | ✓ | | See [issues][llvm16] |+| `clang++` | v3.4 | | | |+| | v3.5 | | | |+| | v3.6 | | | |+| | v3.7 | | | |+| | v3.8 | | | |+| | v3.9 | | | |+| | v4.0 | | | |+| | v5.0 | | | |+| | v6.0 | | | |+| | v7.0 | | ✓ | |+| | v8.0 | | | |++If you encounter problems with the output of *any* compiler, please file [an+issue](https://github.com/GaloisInc/llvm-pretty-bc-parser/issues).++## Documentation++Developers' documentation: [doc/developing.md](./doc/developing.md)++## GHC Support++llvm-pretty-bc-parser endeavors to support three versions of GHC at a time. See+the developers' documentation for more details and a rationale:+[doc/developing.md](./doc/developing.md). Currently supported:++- GHC 9.2.8+- GHC 9.4.5+- GHC 9.6.2++[fuzz-workflow]: https://github.com/GaloisInc/llvm-pretty-bc-parser/blob/master/.github/workflows/llvm-quick-fuzz.yml+[llvm13]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F13.0+[llvm14]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F14.0+[llvm15]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F15.0+[llvm16]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F16.0
disasm-test/Main.hs view
@@ -1,173 +1,805 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Main where -import Data.LLVM.BitCode (parseBitCodeLazyFromFile,Error(..),formatError)-import Text.LLVM.AST (Module)-import Text.LLVM.PP (ppLLVM,ppModule)+import Data.LLVM.BitCode (parseBitCodeLazyFromFile,Error(..),formatError)+import qualified Text.LLVM.AST as AST+import Text.LLVM.PP ( ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, llvmPP ) -import Control.Monad (when)-import Data.Char (ord,isSpace,chr)-import Data.Monoid ( mconcat, Endo(..) )-import Data.Typeable (Typeable)-import System.Console.GetOpt- ( ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo )-import System.Directory (getTemporaryDirectory,removeFile)-import System.Environment (getArgs,getProgName)-import System.Exit (exitFailure,exitSuccess,ExitCode(..))-import System.FilePath ((<.>),dropExtension,takeFileName)-import System.IO- (openBinaryTempFile,hClose,openTempFile,hPrint)-import System.Process- (proc,createProcess,waitForProcess,cmdspec,CmdSpec(..),CreateProcess())-import qualified Control.Exception as X+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 )+import Control.Monad.Trans.State+import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as L+import Data.Char (ord,isLetter,isSpace,chr)+import Data.Generics (everywhere, mkT) -- SYB+import Data.List ( find, isInfixOf, isPrefixOf, isSuffixOf, nub, sort )+import Data.Map ( (!), (!?) )+import qualified Data.Map as Map+import Data.Maybe ( fromMaybe )+import Data.Proxy ( Proxy(..) )+import Data.String.Interpolate+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Versions (Versioning, versioning, prettyV, major, minor)+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+ , listDirectory+ , removeFile )+import System.Exit (ExitCode(..), exitFailure, exitSuccess)+import System.FilePath ( (</>), (<.>) )+import System.IO (openBinaryTempFile,hClose,openTempFile,hPutStrLn)+import qualified System.IO as IO (stderr)+import qualified System.Process as Proc+import Test.Tasty+import Test.Tasty.ExpectedFailure ( ignoreTestBecause+ , expectFailBecause )+import Test.Tasty.HUnit ( 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) +descr :: PP.Doc ann+descr = PP.vcat $+ let block = PPU.reflow in+ [ block [iii|+ This test verifies that the llvm-pretty-bc-parser is capable of+ parsing bitcode properly. This is done by two sets of operations:+ one which uses the llvm-as assembler to generate bitcode from .ll files+ (text assembly in LLVM format), and one which uses the clang compiler to+ generate bitcode from C files; this library should be able to parse both+ types of generated bitcode files.+ |]+ , ""+ , block [iii|+ The assembler test method starts with a known .ll file (LLVM text assembly+ format) and assembles it to LLVM bitcode (via llvm-as from the LLVM tool+ suite). Then the test will use both llvm-dis (from the LLVM tool suite)+ and llvm-disasm (from this package, via direct library calls) to convert+ that bitcode back into the .ll text format, and also (for the latter) into+ an AST representation. [NOTE: C sources should be kept minimal to be focused+ in particular; if too large there are too many opportunities for unrelated+ issues to interfere in successful evaluation.]+ |]+ , ""+ , block [iii|+ The compiler test method starts with a known .c or .cpp file and uses clang to directly+ generate a bitcode file. The test then proceeds just as with the assembler+ test. The only difference therefore is the starting file and first command+ used on that file, but the compiler method will usually generate more variance+ in the bitcode files as the compiler version changes.+ |]+ , ""+ , " +-------------[2nd cycle]------------+"+ , " | |"+ , " v |"+ , " .ll --[llvm-as]--> .bc ---[llvm-dis]--> .ll |"+ , " ^ `-[llvm-disasm]---> .ll"+ , " | `-> .AST"+ , " .c/.cpp --[clang]---+ |"+ , " | [show]"+ , " .bc -[pre-existing]-+ |"+ , " v"+ , " [compare first and second of these:] .txt"+ , ""+ , block [iii|+ The differences between the two .ll text formats+ are displayed for user information, but differences do not constitute a+ test failure. The .ll text file obtained from llvm-disasm is then+ *re-assembled* into another bitcode file, which is again converted back to+ both .ll and AST formats (repeating the above actions, thus any+ differences in the .ll files may be displayed twice. Finally, the two+ AST's are serialized to text and the resulting text is compared for+ differences. The tests will fail if any of the conversion steps fail, or+ if there are differences between the first round-trip .ll file and the+ second round-trip .ll file produced by llvm-pretty-bc-parser.+ |]+ , ""+ , PP.indent 2 $ PP.hang 2 $ block+ [iii|* If opaque pointers are present, *all* pointers are+ converted to opaque pointers. This is because the LLVM+ tools are stricter about opaque pointers, whereas this+ package is more permissive. Opaque pointers are+ the standard in LLVM 15.+ |]+ , ""+ , PP.indent 2 $ PP.hang 2 $ block+ [iii|* Metadata information between the two AST text formats is *not*+ compared (and is actually discarded before serialization, resetting+ all indices to zero). This is because metadata indexes are+ dynamically generated and therefore unstable.+ |]+ , ""+ , PP.indent 2 $ PP.hang 2 $ block+ [iii|* If the --roundtrip-disabled option is specified on the command line,+ then only one assembly-disassembly will be performed and+ the results will not be compared to anything (although any+ llvm-dis/llvm-disasm differences will still be shown).+ This mode ensures that the llvm-disasm will not fail, but+ it does not validate the results.+ |]+ ]+ -- Option Parsing -------------------------------------------------------------- -data Options = Options { optTests :: [FilePath] -- ^ Tests- , optLlvmAs :: String -- ^ llvm-as name- , optLlvmDis :: String -- ^ llvm-dis name- , optHelp :: Bool- } deriving (Show)+newtype LLVMAs = LLVMAs FilePath -defaultOptions :: Options-defaultOptions = Options { optTests = []- , optLlvmAs = "llvm-as"- , optLlvmDis = "llvm-dis"- , optHelp = False- }+defaultLLVMAs :: LLVMAs+defaultLLVMAs = LLVMAs "llvm-as" -options :: [OptDescr (Endo Options)]-options =- [ Option "" ["with-llvm-as"] (ReqArg setLlvmAs "FILEPATH")- "path to llvm-as"- , Option "" ["with-llvm-dis"] (ReqArg setLlvmDis "FILEPATH")- "path to llvm-dis"- , Option "h" ["help"] (NoArg setHelp)- "display this message"- ]+instance TO.IsOption LLVMAs where+ defaultValue = defaultLLVMAs+ parseValue = Just . LLVMAs+ optionName = pure "with-llvm-as"+ optionHelp = pure "path to llvm-as"+ showDefaultValue (LLVMAs as) = Just as+ optionCLParser = TO.mkOptionCLParser $+ OA.metavar "FILEPATH" -setLlvmAs :: String -> Endo Options-setLlvmAs str = Endo (\opt -> opt { optLlvmAs = str })+newtype LLVMDis = LLVMDis FilePath -setLlvmDis :: String -> Endo Options-setLlvmDis str = Endo (\opt -> opt { optLlvmDis = str })+instance TO.IsOption LLVMDis where+ defaultValue = LLVMDis "llvm-dis"+ parseValue = Just . LLVMDis+ optionName = pure "with-llvm-dis"+ optionHelp = pure "path to llvm-dis"+ showDefaultValue (LLVMDis dis) = Just dis+ optionCLParser = TO.mkOptionCLParser $+ OA.metavar "FILEPATH" -setHelp :: Endo Options-setHelp = Endo (\opt -> opt { optHelp = True })+newtype Clang = Clang FilePath -addTest :: String -> Endo Options-addTest test = Endo (\opt -> opt { optTests = test : optTests opt })+instance TO.IsOption Clang where+ defaultValue = Clang "clang"+ parseValue = Just . Clang+ optionName = pure "with-clang"+ optionHelp = pure "path to clang"+ showDefaultValue (Clang dis) = Just dis+ optionCLParser = TO.mkOptionCLParser $+ OA.metavar "FILEPATH" -getOptions :: IO Options-getOptions =- do args <- getArgs- case getOpt (ReturnInOrder addTest) options args of+newtype Roundtrip = Roundtrip Bool - (fs,[],[]) -> do let opts = appEndo (mconcat fs) defaultOptions+instance TO.IsOption Roundtrip where+ defaultValue = Roundtrip True+ parseValue = fmap Roundtrip . TO.safeReadBool+ optionName = pure "roundtrip-disabled"+ optionHelp = pure "disable roundtrip tests (AST/AST diff)"+ showDefaultValue (Roundtrip r) = Just $ show r+ optionCLParser = TO.mkOptionCLParser $+ OA.short 'r' - when (optHelp opts) $ do printUsage []- exitSuccess+newtype Keep = Keep Bool - return opts+instance TO.IsOption Keep where+ defaultValue = Keep False+ parseValue = fmap Keep . TO.safeReadBool+ optionName = pure "keep"+ optionHelp = pure "keep all generated files for manual inspection"+ showDefaultValue (Keep k) = Just $ show k+ optionCLParser = TO.mkOptionCLParser $+ OA.short 'k' - (_,_,errs) -> do printUsage errs- exitFailure+newtype Details = Details Bool -printUsage :: [String] -> IO ()-printUsage errs =- do prog <- getProgName- let banner = "Usage: " ++ prog ++ " [OPTIONS] test1.ll .. testn.ll"- putStrLn (usageInfo (unlines (errs ++ [banner])) options)+instance TO.IsOption Details where+ defaultValue = Details False+ parseValue = fmap Details . TO.safeReadBool+ optionName = pure "details"+ optionHelp = pure "show details of each individual test execution (for debug)"+ showDefaultValue (Details d) = Just $ show d+ optionCLParser = TO.mkOptionCLParser $+ OA.short 'd' +disasmTestIngredients :: VersionCheck -> [TR.Ingredient]+disasmTestIngredients llvmver =+ includingOptions [ TO.Option (Proxy @LLVMAs)+ , TO.Option (Proxy @LLVMDis)+ , TO.Option (Proxy @Clang)+ , TO.Option (Proxy @Roundtrip)+ , TO.Option (Proxy @Keep)+ , TO.Option (Proxy @Details)+ ] :+ TS.sugarIngredients [ assemblyCube llvmver+ , cCompilerCube llvmver+ , ccCompilerCube llvmver ]+ <> defaultIngredients +parseCmdLine :: IO TO.OptionSet+parseCmdLine = do+ TR.installSignalHandlers+ llvmver <- getLLVMAsVersion defaultLLVMAs+ let disasmOptDescrs = TO.uniqueOptionDescriptions $+ TR.coreOptions +++ TS.sugarOptions +++ TR.ingredientsOptions (disasmTestIngredients llvmver)+ (disasmOptWarns, disasmOptParser) = TR.optionParser disasmOptDescrs+ mapM_ (hPutStrLn IO.stderr) disasmOptWarns+ ts <- maybe 80 Term.width <$> Term.size+ let pr = OA.prefs $ OA.columns ts+ OA.customExecParser pr $+ OA.info (OA.helper <*> disasmOptParser)+ ( OA.fullDesc+ <> OA.header "llvm-pretty-bc-parser disassembly test suite"+ <> OA.footerDoc (Just $ PP.align descr)+ )+++-- Querying Tool Versions ------------------------------------------------------++-- | Captures the name of the tool and either the error when attempting to get+-- the tool version or the actual parsed version self-reported by the tool. Lack+-- of a decipherable version is not fatal to running the tests.+data VersionCheck = VC String (Either T.Text Versioning)++showVC :: VersionCheck -> String+showVC (VC nm v) = nm <> " " <> (T.unpack $ either id prettyV v)++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++getLLVMAsVersion :: LLVMAs -> IO VersionCheck+getLLVMAsVersion (LLVMAs llvmAsPath) = getLLVMToolVersion "llvm-as" llvmAsPath++getLLVMDisVersion :: LLVMDis -> IO VersionCheck+getLLVMDisVersion (LLVMDis llvmDisPath) = getLLVMToolVersion "llvm-dis" llvmDisPath++getClangVersion :: Clang -> IO VersionCheck+getClangVersion (Clang clangPath) = getLLVMToolVersion "clang" clangPath++-- 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)+ 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)+ 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 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+ else do putStrLn $ "Warning: IO error attempting to determine " <> forTool <> " version:"+ putStrLn $ show e+ return $ Left "unknown"+ , X.Handler $ \(e :: X.SomeException) -> do+ putStrLn $ "Warning: error attempting to determine " <> forTool <> " version:"+ putStrLn $ show e+ return $ Left "??"+ ]+ -- Test Running ---------------------------------------------------------------- -- | Run all provided tests. main :: IO ()-main = do- opts <- getOptions- mapM_ (runTest opts) (optTests opts)+main = do+ -- This is a bit more involved than a typical tasty `main` function. The+ -- problem is that the number of tests that we generate (via+ -- `withSugarGroups`) depends on the version of the --llvm-as argument,+ -- which must be checked in IO. Unfortunately, a typical+ -- `defaultMainWithIngredients` invocation doesn't allow you to+ -- generate a dynamic number of tests in IO based on argument values. As a+ -- 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++ llvmAsVC <- getLLVMAsVersion llvmAs'+ llvmDisVC <- getLLVMDisVersion llvmDis'+ clangVC <- getClangVersion clang'+ unless (and [ vcVersioning llvmAsVC == vcVersioning llvmDisVC+ , vcVersioning llvmAsVC == vcVersioning clangVC+ ]) $+ 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+ ]++ knownBugs <- getKnownBugs+ sweets1 <- TS.findSugar $ assemblyCube llvmAsVC+ sweets2 <- TS.findSugar $ cCompilerCube llvmAsVC+ sweets3 <- TS.findSugar $ ccCompilerCube llvmAsVC+ sweets4 <- TS.findSugar $ bitcodeCube llvmAsVC+ atests <- TS.withSugarGroups sweets1 testGroup+ $ \s _ e -> runAssemblyTest llvmAsVC knownBugs s e+ ctests <- TS.withSugarGroups sweets2 testGroup+ $ \s _ e -> runCompileTest llvmAsVC knownBugs s e+ cctests <- TS.withSugarGroups sweets3 testGroup+ $ \s _ e -> runCompileTest llvmAsVC knownBugs s e+ bctests <- TS.withSugarGroups sweets4 testGroup+ $ \s _ e -> runRawBCTest llvmAsVC knownBugs s e+ let tests = atests <> ctests+ case TR.tryIngredients+ (disasmTestIngredients llvmAsVC)+ disasmOpts+ (testGroup "Disassembly tests"+ [ testGroup ("llvm-as " <> showVC llvmAsVC) atests+ , testGroup ("C " <> showVC clangVC) ctests+ , testGroup ("C++ " <> showVC clangVC) cctests+ , testGroup ("rawBC " <> showVC llvmAsVC) bctests+ ]) of+ Nothing ->+ hPutStrLn IO.stderr+ "No ingredients agreed to run. Something is wrong either with your ingredient set or the options."+ Just act -> do+ ok <- act+ if ok then exitSuccess else exitFailure++ defaultMainWithIngredients (disasmTestIngredients llvmAsVC) $+ testGroup "Disassembly tests" tests++----------------------------------------------------------------------+-- Assembly/disassembly tests++assemblyCube :: VersionCheck -> TS.CUBE+assemblyCube llvmver = TS.mkCUBE+ { TS.inputDirs = ["disasm-test/tests"]+ , TS.rootName = "*.ll"+ , TS.separators = "."+ , TS.validParams = [ ("llvm-range", Just [ "recent-llvm"+ , "pre-llvm12"+ , "pre-llvm13"+ , "pre-llvm14"+ , "pre-llvm15"+ ])+ ]+ -- Somewhat unusually for tasty-sugar, we make the expectedSuffix the same+ -- as the rootName suffix. This is because we are comparing the contents of+ -- each .ll file against *itself* after parsing it with+ -- llvm-pretty-bc-parser, pretty-printing it with llvm-pretty, and+ -- then normalizing it. As such, each .ll file acts as its own golden file.+ , TS.expectedSuffix = "ll"+ , TS.sweetAdjuster = \cb ->+ -- In addition to range matching, this is a round-trip test (assemble ++ -- disassemble) where the rootname is the same as the expected name.+ -- Filter out any expectations that don't match the root name.+ -- (e.g. remove: root=poison.ll with exp=poison.pre-llvm12.ll).+ let rootExpSame s e = TS.rootFile s == TS.expectedFile e+ addExpFilter s = s { TS.expected = filter (rootExpSame s) $ TS.expected s }+ in fmap (fmap addExpFilter) . rangeMatch llvmver cb+ }+++rangeMatch :: MonadIO m => VersionCheck -> TS.CUBE -> [TS.Sweets] -> m [TS.Sweets]+rangeMatch llvmver cb swts = do+ -- Perform ranged-matching of the llvm-range parameter against the version of+ -- llvm (reported by llvm-as) to filter the tasty-sugar expectations. Note+ -- that there is a built-in expectation here that there is only one llvm+ -- version available to the test.+ TS.rangedParamAdjuster "llvm-range"+ (readMaybe . drop (length ("pre-llvm" :: String)))+ (<)+ (vcVersioning llvmver ^? (_Right . major))+ cb swts+++-- | Returns true if this particular test should be skipped, which is signalled+-- by the expected file contents starting with "SKIP_TEST". For test cases that+-- require a minimum LLVM version, this technique is used to prevent running the+-- test on older LLVM versions.+skipTest :: TS.Expectation -> IO Bool+skipTest expct =+ ("SKIP_TEST" `L.isPrefixOf`) <$> L.readFile (TS.expectedFile expct)+++-- | Attempt to compare the assembly generated by llvm-pretty and llvm-dis.+runAssemblyTest :: VersionCheck -> KnownBugs -> TS.Sweets -> TS.Expectation+ -> IO [TestTree]+runAssemblyTest llvmVersion knownBugs sweet expct+ = do shouldSkip <- skipTest expct+ let tmod = if shouldSkip+ then ignoreTestBecause "not valid for this LLVM version"+ else case isKnownBug knownBugs sweet expct llvmVersion of+ Just (from, why) ->+ expectFailBecause $ why <> " [see " <> from <> "]"+ Nothing -> id+ let pfx = TS.rootBaseName sweet+ return $ (:[]) $ tmod+ $ testCaseM llvmVersion pfx+ $ with2Files (processLL pfx $ TS.rootFile sweet)+ $ \(parsed1, ast) ->+ case ast of+ Nothing -> return ()+ Just ast1 ->+ -- Re-assemble and re-disassemble+ with2Files (processLL pfx parsed1)+ $ \(_, mb'ast2) ->+ case mb'ast2 of+ Just ast2 -> diffCmp ast1 ast2 -- Ensure that the ASTs match++ -- Ensure that the disassembled files match.+ -- This is usually too strict (and doesn't+ -- really provide more info). We normalize+ -- the AST (see below) to ensure that the+ -- ASTs match modulo metadata numbering, but+ -- the equivalent isn't possible for the+ -- assembly: we need llvm-as to be able to+ -- re-assemble it.+ --+ -- diffCmp parsed1 parsed2+ Nothing -> error "Failed processLL"+++diffCmp :: FilePath -> FilePath -> TestM ()+diffCmp file1 file2 = do+ let assertF = liftIO . assertFailure . unlines+ (code, stdout, stderr) <- liftIO $+ Proc.readCreateProcessWithExitCode (Proc.proc "diff" ["-u", file1, file2]) ""+ case code of+ ExitFailure _ -> assertF ["diff failed", stdout, stderr]+ ExitSuccess ->+ if stdout /= "" || stderr /= ""+ then assertF ["non-empty diff", stdout, stderr]+ else do Details det <- gets showDetails+ when det $ liftIO+ $ mapM_ putStrLn ["success: empty diff: ", file1, file2]+++-- Assembles the specified .ll file to bitcode, then disassembles it with+-- llvm-dis. Also parses the bitcode with this library (effectively llvm-disasm)+-- and prints the difference between the parsed version and the .ll file.+-- Returns the library parsed version and the serialized AST from the library.++processLL :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath)+processLL pfx f = do+ Details det <- gets showDetails+ when det $ liftIO $ putStrLn (showString f ": ")+ X.handle logError+ $ withFile (assembleToBitCode pfx f)+ $ parseBC pfx+ where+ logError (ParseError msg) =+ liftIO $ assertFailure $ unlines+ $ "failure" : map ("; " ++) (lines (formatError msg))++parseBC :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath)+parseBC pfx bc = do+ withFile (X.handle+ (\(_ :: GE.IOException) -> return "LLVM llvm-dis failed to parse this file")+ (disasmBitCode pfx bc))+ $ \ norm -> do+ (parsed, ast) <- processBitCode pfx bc+ Details dets <- gets showDetails+ when dets $ liftIO $ do+ -- Informationally display if there are differences between the llvm-dis+ -- and llvm-disasm outputs, but no error if they differ. Note that the+ -- arguments to this diff are not the same as those supplied to the diffCmp+ -- function. The diff here is intended to supply additional information to+ -- the user for diagnostics, and whitespace changes are likely unimportant+ -- in that context; this diff does not determine the pass/fail status of+ -- the testing. On the other hand, the diffCmp *does* determine if the+ -- tests pass or fail, so ignoring whitespace in that determination would+ -- potentially weaken the testing to an unsatisfactory degree and would+ -- need more careful evaluation.+ putStrLn "## Output differences: LLVM's llvm-dis <--> this llvm-disasm"+ ignore (Proc.callProcess "diff" ["-u", "-b", "-B", "-w", norm, parsed])+ putStrLn ("successfully parsed " ++ show pfx ++ " bitcode")+ return (parsed, ast)++----------------------------------------------------------------------+-- Compiler->Assembly->Disassembly tests++-- The compilation tests ensure that the clang version-specific generated .bc+-- file can be reasonably parsed by this library. This is a parallel to the+-- assemblyCube-driven tests, but starts with a C source file. One distinction+-- is that the .ll used for the assemblyCube is typically representative of a+-- specific LLVM version, and while it is assembled and disassembled by newer+-- versions of LLVM tools, it will never introduce any newer element, whereas the+-- clang-generated bitcode will contain version-current output which might have+-- newer elements and ordering.+--+-- The cCompilerCube uses .c (C source) files as the input and .ll files for the+-- expected output. The ccCompilerCube uses .cc (C++ source) files as the input+-- and .ll files for the expected output. The assemblyCube uses the .ll file as+-- both input and output. The actual testing done is very similar, and the+-- assemblyCube always generates a superset of the compilerCube tests (i.e. when+-- no .c or .cc file is present).++cCompilerCube :: VersionCheck -> TS.CUBE+cCompilerCube llvmver = (assemblyCube llvmver)+ { TS.rootName = "*.(c|cc|cpp)"+ , TS.sweetAdjuster = rangeMatch llvmver+ }++ccCompilerCube :: VersionCheck -> TS.CUBE+ccCompilerCube llvmver = (cCompilerCube llvmver) { TS.rootName = "*.cc"}+++runCompileTest :: VersionCheck -> KnownBugs -> TS.Sweets -> TS.Expectation+ -> IO [TestTree]+runCompileTest llvmVersion knownBugs sweet expct = do+ shouldSkip <- skipTest expct+ let tmod = if shouldSkip+ then ignoreTestBecause "not valid for this LLVM version"+ else case isKnownBug knownBugs sweet expct llvmVersion of+ Just (from, why) ->+ expectFailBecause $ why <> " [see " <> from <> "]"+ Nothing -> id+ let pfx = TS.rootBaseName sweet+ return $ (:[]) $ tmod+ $ testCaseM llvmVersion pfx+ $ withFile (compileToBitCode pfx $ TS.rootFile sweet)+ $ \bc ->+ with2Files (parseBC pfx bc)+ $ \(parsed1, ast) ->+ case ast of+ Nothing ->+ -- No round trip, so this just verifies that the bitcode could be+ -- parsed without generating an error.+ return ()+ Just ast1 ->+ -- Assemble and re-parse the bitcode to make sure it can be+ -- round-tripped successfully.+ with2Files (processLL pfx parsed1)+ $ \(_, mb'ast2) -> case mb'ast2 of+ Just ast2 -> diffCmp ast1 ast2+ Nothing -> error "failed processLL"+ -- fst is ignored because .ll files are not compared; see+ -- runAssemblyTest for details.+++----------------------------------------------------------------------+-- Pre-existing bitcode tests tests++bitcodeCube :: VersionCheck -> TS.CUBE+bitcodeCube llvmver = (assemblyCube llvmver)+ { TS.rootName = "*.bc"+ , TS.inputDirs = ["disasm-test/bc_src_tests"]+ , TS.sweetAdjuster = rangeMatch llvmver+ }++runRawBCTest :: VersionCheck -> KnownBugs -> TS.Sweets -> TS.Expectation+ -> IO [TestTree]+runRawBCTest llvmVersion knownBugs sweet expct = do+ shouldSkip <- skipTest expct+ let tmod = if shouldSkip+ then ignoreTestBecause "not valid for this LLVM version"+ else case isKnownBug knownBugs sweet expct llvmVersion of+ Just (from, why) ->+ expectFailBecause $ why <> " [see " <> from <> "]"+ Nothing -> id+ let pfx = TS.rootBaseName sweet+ let bc = TS.rootFile sweet+ return $ (:[]) $ tmod+ $ testCaseM llvmVersion pfx+ $ with2Files (parseBC pfx bc)+ $ \(parsed1, ast) ->+ case ast of+ Nothing ->+ -- No round trip, so this just verifies that the bitcode could be+ -- parsed without generating an error.+ return ()+ Just ast1 ->+ -- Assemble and re-parse the bitcode to make sure it can be+ -- round-tripped successfully.+ with2Files (processLL pfx parsed1)+ $ \(_, mb'ast2) -> case mb'ast2 of+ Just ast2 -> diffCmp ast1 ast2+ Nothing -> error "Failed processLL"+ -- fst is ignored because .ll files are not compared; see+ -- runAssemblyTest for details.+++----------------------------------------------------------------------+-- Helpers+ -- | A test failure. data TestFailure- = ParseError Error -- ^ A parser failure.+ = ParseError Error -- ^ A parser failure deriving (Typeable,Show) instance X.Exception TestFailure --- | Attempt to compare the assembly generated by llvm-pretty and llvm-dis.-runTest :: Options -> FilePath -> IO ()-runTest opts file = do- putStr (showString file ":")- X.handle logError $- X.handle logCommandError $- X.bracket (generateBitCode opts pfx file) removeFile $ \ bc ->- X.bracket (normalizeBitCode opts pfx bc) removeFile $ \ norm ->- X.bracket (processBitCode pfx bc) removeFile $ \ parsed -> do- ignore (wait (proc "diff" ["-u",norm,parsed]))- putStrLn "success"- where- pfx = dropExtension (takeFileName file) - logError (ParseError msg) = do- putStrLn "failure"- putStrLn (unlines (map ("; " ++) (lines (formatError msg))))+-- This structure essentially recapitulates the TestOptions, but in a way that+-- they will be accessible in a TestTree (via: StateT TestState IO a).+data TestState = TestState { keepTemp :: Keep+ , rndTrip :: Roundtrip+ , showDetails :: Details+ , llvmAs :: LLVMAs+ , llvmDis :: LLVMDis+ , clang :: Clang+ , llvmVer :: VersionCheck+ } - logCommandError (CommandFailed cmd) = do- putStrLn "failure"- putStrLn ("Command ``" ++ cmd ++ "'' failed\n\n")+type TestM a = StateT TestState IO a +testCaseM :: VersionCheck -> FilePath -> TestM () -> TestTree+testCaseM llvmVersion pfx ops =+ askOption $ \llvmAs' ->+ askOption $ \llvmDis' ->+ askOption $ \roundtrip ->+ askOption $ \keep ->+ askOption $ \details ->+ askOption $ \clang' ->+ testCase pfx $ evalStateT ops (TestState { keepTemp = keep+ , rndTrip = roundtrip+ , showDetails = details+ , llvmAs = llvmAs'+ , llvmDis = llvmDis'+ , clang = clang'+ , llvmVer = llvmVersion+ })++ -- | Assemble some llvm assembly, producing a bitcode file in /tmp.-generateBitCode :: Options -> FilePath -> FilePath -> IO FilePath-generateBitCode Options { .. } pfx file = do- tmp <- getTemporaryDirectory- (bc,h) <- openBinaryTempFile tmp (pfx <.> "bc")- hClose h- wait (proc optLlvmAs ["-o", bc, file])- return bc+assembleToBitCode :: FilePath -> FilePath -> TestM FilePath+assembleToBitCode pfx file = do+ tmp <- liftIO getTemporaryDirectory+ LLVMAs asm <- gets llvmAs+ X.bracketOnError+ (liftIO $ openBinaryTempFile tmp (pfx <.> "bc"))+ (rmFile . fst)+ $ \(bc,h) ->+ do liftIO $ hClose h+ callProc asm ["-o", bc, file]+ return bc +-- | Compile a C or C++ source, producing a bitcode file in /tmp.+compileToBitCode :: FilePath -> FilePath -> TestM FilePath+compileToBitCode pfx file = do+ tmp <- liftIO getTemporaryDirectory+ Clang comp' <- gets clang+ let comp = if ".cc" `isSuffixOf` file then comp' <> "++" else comp'+ X.bracketOnError+ (liftIO $ openBinaryTempFile tmp (pfx <.> "bc"))+ (rmFile . fst)+ $ \(bc,h) ->+ do liftIO $ hClose h+ callProc comp ["-c", "-emit-llvm", "-O0", "-U_FORTIFY_SOURCE", "-g", "-o", bc, file]+ return bc+ -- | Use llvm-dis to parse a bitcode file, to obtain a normalized version of the -- llvm assembly.-normalizeBitCode :: Options -> FilePath -> FilePath -> IO FilePath-normalizeBitCode Options { .. } pfx file = do- tmp <- getTemporaryDirectory- (norm,h) <- openTempFile tmp (pfx <.> "ll")- hClose h- wait (proc optLlvmDis ["-o", norm, file])- stripComments norm- return norm+disasmBitCode :: FilePath -> FilePath -> TestM FilePath+disasmBitCode pfx file = do+ tmp <- liftIO $ getTemporaryDirectory+ LLVMDis dis <- gets llvmDis+ X.bracketOnError+ (liftIO $ openTempFile tmp (pfx ++ "llvm-dis" <.> "ll"))+ (rmFile . fst)+ $ \(norm,h) ->+ do liftIO $ hClose h+ callProc dis ["-o", norm, file]+ -- stripComments norm+ return norm +-- | Usually, the ASTs aren't "on the nose" identical.+-- The big thing is that the metadata numbering differs, so we zero out all+-- metadata indices and sort the unnamed metadata list.+-- Done with SYB (Scrap Your Boilerplate).+normalizeModule :: AST.Module -> AST.Module+normalizeModule = sorted . everywhere (mkT zeroValMdRef)+ . everywhere (mkT zeroNamedMd)+ where sorted m = m { AST.modUnnamedMd =+ sort (map (\um -> um { AST.umIndex = 0 })+ (AST.modUnnamedMd m)) }+ -- Zero out all ValMdRefs+ zeroValMdRef (AST.ValMdRef _) = AST.ValMdRef 0+ zeroValMdRef a = (a :: AST.ValMd) -- avoid ambiguous type++ -- Reduce all named metadata+ zeroNamedMd (AST.NamedMd x _) = AST.NamedMd x []++ -- | Parse a bitcode file using llvm-pretty, failing the test if the parser -- fails.-processBitCode :: FilePath -> FilePath -> IO FilePath+processBitCode :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath) processBitCode pfx file = do- let handler :: X.SomeException -> IO (Either Error Module)+ let handler :: X.SomeException -> IO (Either Error AST.Module) handler se = return (Left (Error [] (show se)))- e <- parseBitCodeLazyFromFile file `X.catch` handler+ printToTempFile sufx stuff = do+ tmp <- getTemporaryDirectory+ (parsed,h) <- openTempFile tmp (pfx ++ "llvm-disasm" <.> sufx)+ hPutStrLn h stuff+ hClose h+ return parsed+ e <- liftIO $ parseBitCodeLazyFromFile file `X.catch` handler case e of- Left err -> X.throwIO (ParseError err)+ Left err -> X.throwM (ParseError err) Right m -> do- tmp <- getTemporaryDirectory- (parsed,h) <- openTempFile tmp (pfx <.> "ll")- hPrint h (ppLLVM (ppModule m))- hClose h- stripComments parsed- return parsed+ 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'+ parsed <- liftIO $ printToTempFile "ll" $ show llvmAssembly+ Roundtrip roundtrip <- gets rndTrip+ -- stripComments parsed+ Details det <- gets showDetails+ if roundtrip+ then do+ tmp2 <- liftIO $ printToTempFile "ast" (ppShow (normalizeModule m'))+ when det $ liftIO $ putStrLn $ "## parsed Bitcode to " <> parsed <> " and " <> tmp2+ return (parsed, Just tmp2)+ else do+ when det $ liftIO $ putStrLn $ "## parsed Bitcode to " <> parsed+ return (parsed, Nothing) ++-- | These are common tests that should be run on the AST that is parsed from the+-- bitcode file. This tests invariants that are not accessible or testable from+-- the serialized formats.+postParseTests :: AST.Module -> TestM ()+postParseTests m = ensureValidMetadataIndices m+ where+ -- This test is to ensure that all unnamed metadata instances have a unique+ -- index value.+ ensureValidMetadataIndices md = do+ let idxs = AST.umIndex <$> AST.modUnnamedMd md+ let uniqIdxs = nub idxs+ let numDups = length idxs - length uniqIdxs+ unless (numDups == 0)+ $ do Details det <- gets showDetails+ when det $ liftIO $ putStrLn+ $ "Unnamed metadata (modUnnamedMd) indices: " <> show idxs+ liftIO $ assertFailure+ $ show numDups+ <> " duplicated Unnamed metadata (modUnnamedMd) indices"+++ -- | Remove comments from a .ll file, stripping everything including the -- semi-colon.-stripComments :: FilePath -> IO ()+stripComments :: FilePath -> TestM () stripComments path = do- bytes <- L.readFile path- removeFile path+ Keep keep <- gets keepTemp+ bytes <- liftIO $ L.readFile path+ when (not keep) $ rmFile path mapM_ (writeLine . dropComments) (bsLines bytes) where writeLine bs | L.null bs = return ()- | otherwise = do+ | otherwise = liftIO $ do L.appendFile path bs L.appendFile path (L.singleton 0x0a) @@ -193,30 +825,94 @@ loop n | isSpace (chr (fromIntegral (L.index bs n))) = loop (n-1) | otherwise = n --- | A shell-command failure.-data CommandError- = CommandFailed String -- ^ The command failed when running.- deriving (Typeable,Show)+-- | Ignore a command that fails.+ignore :: IO () -> IO ()+ignore = X.handle f+ where f :: EX.IOException -> IO ()+ f _ = return () -instance X.Exception CommandError+callProc :: String -> [String] -> TestM ()+callProc p args = do+ Details dets <- gets showDetails+ when dets $ liftIO $ putStrLn ("## Running: " ++ p ++ " " ++ unwords args)+ liftIO $ Proc.callProcess p args --- | Construct a command error, given a description of the command that was run.-commandError :: CmdSpec -> CommandError-commandError (ShellCommand str) = CommandFailed str-commandError (RawCommand p args) = CommandFailed (unwords (takeFileName p:args))+withFile :: TestM FilePath -> (FilePath -> TestM r) -> TestM r+withFile iofile f = X.bracket iofile rmFile f --- | Run a command, waiting for it to return.-wait :: CreateProcess -> IO ()-wait cmd = do- (_,_,_,ph) <- createProcess cmd- status <- waitForProcess ph- case status of- ExitFailure{} -> X.throwIO (commandError (cmdspec cmd))- _ -> return ()+with2Files :: TestM (FilePath, Maybe FilePath)+ -> ((FilePath, Maybe FilePath) -> TestM r)+ -> TestM r+with2Files iofiles f =+ let cleanup (tmp1, mbTmp2) = do+ rmFile tmp1+ traverse rmFile mbTmp2+ in X.bracket iofiles cleanup f --- | Ignore a command that fails.-ignore :: IO () -> IO ()-ignore = X.handle f- where- f :: CommandError -> IO ()- f _ = return ()+rmFile :: FilePath -> TestM ()+rmFile tmp = do Keep keep <- gets keepTemp+ unless keep+ $ do do exists <- liftIO $ doesFileExist tmp+ when exists $ do+ Details dets <- gets showDetails+ when dets $ liftIO $ putStrLn $ "## Removing " <> tmp+ liftIO $ removeFile tmp++----------------------------------------------------------------------++-- Handling Known Bugs++-- | A map from a known bug file to the identifiers and identifier values in that+-- known bug file.+type KnownBugs = Map.Map FilePath (Map.Map String [String])++-- | There is a directory containing files which describe known bugs (one per+-- file). Those files contain marker lines (prefixed with "##> ") which specify+-- the elements and values that should match a test for this test to be a known+-- bug. This function reads in that file and creates a map from file to a map of+-- markers and values in that file. This returned value should be passed to the+-- isKnownBug function, along with the test information to determine if the test+-- is associated with a known bug.+getKnownBugs :: IO KnownBugs+getKnownBugs = do+ let kbdir = "disasm-test/known_bugs"+ known <- listDirectory kbdir+ let interestingLine = ("##> " `isPrefixOf`)+ let addInterestingLine l = case words l of+ (_ : t : ws) -> Map.insertWith (<>) t ws+ _ -> id+ let interestingLineMap ls = foldr addInterestingLine mempty+ $ filter interestingLine ls+ let addKnownBugInfo mp f = do+ let fpath = kbdir </> f+ X.try (lines <$> readFile fpath) >>= \case+ Left (_e :: IOError) ->+ -- Error reading the known bug file: ignore it+ return mp+ Right ls ->+ let buginfo = interestingLineMap ls+ in return $ if Map.null buginfo+ then mp+ else Map.insert fpath buginfo mp+ foldM addKnownBugInfo mempty known+++-- | This function checks to see if the current test being defined corresponds to+-- one of those known bugs, and if so, returns the name of the known bugs file+-- and the summary string from that file.+isKnownBug :: KnownBugs -> TS.Sweets -> TS.Expectation -> VersionCheck+ -> Maybe (FilePath, String)+isKnownBug knownBugs sweet _expct llvmver =+ let matchOf (_,km) = and (uncurry isMatch <$> Map.assocs km)+ isMatch = \case+ "rootMatchName:" -> (TS.rootMatchName sweet `elem`)+ "llvmver:" -> case vcVersioning llvmver ^? (_Right . major) of+ Just v -> (show v `elem`)+ Nothing -> const False+ _ -> const True+ found = find matchOf $ Map.assocs knownBugs+ getSummary (f,_) = (f+ , head (fromMaybe [] (knownBugs ! f !? "summary:")+ <> ["this is a known bug"])+ )+ in getSummary <$> found
+ disasm-test/tests/T189.ll view
@@ -0,0 +1,29 @@+; ModuleID = 'T189.c'+source_filename = "T189.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-pc-linux-gnu"++@.str = private unnamed_addr constant [4 x i8] c"%d\0A\00", align 1++; Function Attrs: noinline nounwind optnone uwtable+define dso_local void @f() #0 {+entry:+ %p = alloca i32 (i8*, ...)*, align 8+ store i32 (i8*, ...)* @printf, i32 (i8*, ...)** %p, align 8+ %0 = load i32 (i8*, ...)*, i32 (i8*, ...)** %p, align 8+ %call = call i32 (i8*, ...) %0(i8* getelementptr inbounds ([4 x i8], [4 x i8]* @.str, i64 0, i64 0), i32 0)+ ret void+}++declare dso_local i32 @printf(i8*, ...) #1++attributes #0 = { noinline nounwind optnone uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }++!llvm.module.flags = !{!0}+!llvm.ident = !{!1}+!llvm.commandline = !{!2}++!0 = !{i32 1, !"wchar_size", i32 4}+!1 = !{!"clang version 10.0.0-4ubuntu1 "}+!2 = !{!"/usr/lib/llvm-10/bin/clang -S -emit-llvm -frecord-command-line -fno-discard-value-names T189.c -o T189.ll"}
+ disasm-test/tests/T266-constant-icmp.ll view
@@ -0,0 +1,7 @@+@global_var = external constant [1 x i8]++define i64 @h() {+ br i1 icmp ne (i32 ptrtoint (ptr @global_var to i32), i32 1), label %pc_1, label %pc_1+pc_1:+ ret i64 0+}
+ disasm-test/tests/T266-constant-icmp.pre-llvm15.ll view
@@ -0,0 +1,7 @@+@global_var = external constant [1 x i8]++define i64 @h() {+ br i1 icmp ne (i32 ptrtoint ([1 x i8]* @global_var to i32), i32 1), label %pc_1, label %pc_1+pc_1:+ ret i64 0+}
− disasm-test/tests/alloca.ll
@@ -1,10 +0,0 @@-; ModuleID = 'alloca.bc'--%aaaa = type [1 x i32]--define i32 @f() {- %arr = alloca %aaaa, align 4- %ptr = getelementptr %aaaa* %arr, i32 0, i32 0- store i32 0, i32* %ptr- ret i32 0-}
+ disasm-test/tests/atomicrmw.ll view
@@ -0,0 +1,4 @@+define void @atomicrmw(i32* %a, i32 %i) {+ %b = atomicrmw add i32* %a, i32 %i acquire+ ret void+}
+ disasm-test/tests/btf-tag-dicompositetype.ll view
@@ -0,0 +1,10 @@+;; https://github.com/llvm/llvm-project/blob/0b32dca12ef4d82af71f86a70c49806e5b81ead2/llvm/test/Bitcode/attr-btf_tag-dicomposite.ll++!3 = !DIFile(filename: "struct.c", directory: "/home/yhs/work/tests/llvm/btf_tag")+!6 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "t", file: !3, line: 1, size: 32, elements: !7, annotations: !10)+!7 = !{!8}+!8 = !DIDerivedType(tag: DW_TAG_member, name: "a", scope: !6, file: !3, line: 1, baseType: !9, size: 32)+!9 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!10 = !{!11, !12}+!11 = !{!"btf_tag", !"a"}+!12 = !{!"btf_tag", !"b"}
+ disasm-test/tests/btf-tag-dicompositetype.pre-llvm14.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/btf-tag-diderivedtype.ll view
@@ -0,0 +1,10 @@+;; Adapted from https://github.com/llvm/llvm-project/blob/430e22388173c96da6777fccb9735a6e8ee3ea1c/llvm/test/Bitcode/attr-btf_tag-field.ll++!1 = !DIFile(filename: "attr-btf_tag-field.c", directory: "/home/yhs/work/tests/llvm/btf_tag")+!12 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!14 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "t1", file: !1, line: 7, size: 32, elements: !15)+!15 = !{!16}+!16 = !DIDerivedType(tag: DW_TAG_member, name: "a", scope: !14, file: !1, line: 8, baseType: !12, size: 32, annotations: !17)+!17 = !{!18, !19}+!18 = !{!"btf_tag", !"tag1"}+!19 = !{!"btf_tag", !"tag2"}
+ disasm-test/tests/btf-tag-diderivedtype.pre-llvm14.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/btf-tag-diglobalvariable.ll view
@@ -0,0 +1,15 @@+;; Adapted from https://github.com/llvm/llvm-project/blob/30c288489ae51a3e0819241f367eeae6df2b09e7/llvm/test/Bitcode/attr-btf_tag-diglobalvariable.ll++!0 = !DIGlobalVariableExpression(var: !1, expr: !DIExpression())+!1 = distinct !DIGlobalVariable(name: "g1", scope: !2, file: !3, line: 7, type: !6, isLocal: false, isDefinition: true, annotations: !10)+!2 = distinct !DICompileUnit(language: DW_LANG_C99, file: !3, producer: "clang version 13.0.0 (https://github.com/llvm/llvm-project.git 47af5574a87dc298b5c6c36ff6a969c8c77c8499)", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !4, globals: !5, splitDebugInlining: false, nameTableKind: None)+!3 = !DIFile(filename: "t.c", directory: "/home/yhs/work/tests/llvm/btf_tag")+!4 = !{}+!5 = !{!0}+!6 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "t1", file: !3, line: 4, size: 32, elements: !7)+!7 = !{!8}+!8 = !DIDerivedType(tag: DW_TAG_member, name: "a", scope: !6, file: !3, line: 5, baseType: !9, size: 32)+!9 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!10 = !{!11, !12}+!11 = !{!"btf_tag", !"tag1"}+!12 = !{!"btf_tag", !"tag2"}
+ disasm-test/tests/btf-tag-diglobalvariable.pre-llvm14.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/btf-tag-dilocalvariable.ll view
@@ -0,0 +1,14 @@+;; Adapted from https://github.com/llvm/llvm-project/blob/1bebc31c617d1a0773f1d561f02dd17c5e83b23b/llvm/test/Bitcode/attr-btf_tag-parameter.ll++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 13.0.0 (https://github.com/llvm/llvm-project.git c9e3139e00bcef23b236a02890b909a130d1b3d9)", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "func.c", directory: "/home/yhs/work/tests/llvm/btf_tag")+!2 = !{}+!8 = distinct !DISubprogram(name: "f", scope: !1, file: !1, line: 1, type: !9, scopeLine: 1, flags: DIFlagPrototyped | DIFlagAllCallsDescribed, spFlags: DISPFlagDefinition | DISPFlagOptimized, unit: !0, retainedNodes: !12)+!9 = !DISubroutineType(types: !10)+!10 = !{!11, !11}+!11 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!12 = !{!13}+!13 = !DILocalVariable(name: "a", arg: 1, scope: !8, file: !1, line: 1, type: !11, annotations: !14)+!14 = !{!15, !16}+!15 = !{!"btf_tag", !"a"}+!16 = !{!"btf_tag", !"b"}
+ disasm-test/tests/btf-tag-dilocalvariable.pre-llvm14.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/btf-tag-disubprogram.ll view
@@ -0,0 +1,15 @@+;; Adapted from https://github.com/llvm/llvm-project/blob/d383df32c0d5bcdc8c160ecdd7174399aa3c5395/llvm/test/Bitcode/attr-btf_tag-disubprogram.ll++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 13.0.0 (https://github.com/llvm/llvm-project.git a6dd9d402a04d53403664bbb47771f2573c7ade0)", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "func.c", directory: "/home/yhs/work/tests/llvm/btf_tag")+!2 = !{}+!7 = !{!"clang version 13.0.0 (https://github.com/llvm/llvm-project.git a6dd9d402a04d53403664bbb47771f2573c7ade0)"}+!8 = distinct !DISubprogram(name: "f", scope: !1, file: !1, line: 1, type: !9, scopeLine: 1, flags: DIFlagPrototyped | DIFlagAllCallsDescribed, spFlags: DISPFlagDefinition | DISPFlagOptimized, unit: !0, retainedNodes: !12, annotations: !14)+!9 = !DISubroutineType(types: !10)+!10 = !{!11, !11}+!11 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!12 = !{!13}+!13 = !DILocalVariable(name: "a", arg: 1, scope: !8, file: !1, line: 1, type: !11)+!14 = !{!15, !16}+!15 = !{!"btf_tag", !"a"}+!16 = !{!"btf_tag", !"b"}
+ disasm-test/tests/btf-tag-disubprogram.pre-llvm14.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/callbr.ll view
@@ -0,0 +1,47 @@+; ModuleID = 'callbr.c'+source_filename = "callbr.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++; Function Attrs: noinline nounwind optnone uwtable+define dso_local i32 @main() #0 {+ %1 = alloca i32, align 4+ %2 = alloca i32, align 4+ store i32 0, ptr %1, align 4+ store i32 0, ptr %2, align 4+ %3 = load i32, ptr %2, align 4+ callbr void asm sideeffect "testl $0, $0; jne ${1:l};", "r,!i,!i,~{dirflag},~{fpsr},~{flags}"(i32 %3) #1+ to label %4 [label %6, label %5], !srcloc !7++4: ; preds = %0+ store i32 0, ptr %1, align 4+ br label %7++5: ; preds = %0+ store i32 0, ptr %1, align 4+ br label %7++6: ; preds = %0+ store i32 1, ptr %1, align 4+ br label %7++7: ; preds = %6, %5, %4+ %8 = load i32, ptr %1, align 4+ ret i32 %8+}++attributes #0 = { noinline nounwind optnone uwtable "frame-pointer"="all" "min-legal-vector-width"="0" "no-trapping-math"="true" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "tune-cpu"="generic" }+attributes #1 = { nounwind }++!llvm.module.flags = !{!0, !1, !2, !3, !4}+!llvm.ident = !{!5}+!llvm.commandline = !{!6}++!0 = !{i32 1, !"wchar_size", i32 4}+!1 = !{i32 7, !"PIC Level", i32 2}+!2 = !{i32 7, !"PIE Level", i32 2}+!3 = !{i32 7, !"uwtable", i32 2}+!4 = !{i32 7, !"frame-pointer", i32 2}+!5 = !{!"clang version 15.0.6"}+!6 = !{!"/home/ryanglscott/Software/clang+llvm-15.0.6/bin/clang-15 -S -emit-llvm -frecord-command-line callbr.c -o callbr.ll"}+!7 = !{i64 272}
+ disasm-test/tests/callbr.pre-llvm15.ll view
@@ -0,0 +1,40 @@+; ModuleID = 'test.c'+source_filename = "test.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-pc-linux-gnu"++; Function Attrs: noinline nounwind optnone uwtable+define dso_local i32 @test1(i32 %0) #0 {+ %2 = alloca i32, align 4+ %3 = alloca i32, align 4+ store i32 %0, i32* %3, align 4+ %4 = load i32, i32* %3, align 4+ callbr void asm sideeffect "testl $0, $0; jne ${1:l};", "r,X,X,~{dirflag},~{fpsr},~{flags}"(i32 %4, i8* blockaddress(@test1, %7), i8* blockaddress(@test1, %6)) #1+ to label %5 [label %7, label %6], !srcloc !2++5: ; preds = %1+ store i32 0, i32* %2, align 4+ br label %8++6: ; preds = %1+ store i32 0, i32* %2, align 4+ br label %8++7: ; preds = %1+ store i32 1, i32* %2, align 4+ br label %8++8: ; preds = %7, %6, %5+ %9 = load i32, i32* %2, align 4+ ret i32 %9+}++attributes #0 = { noinline nounwind optnone uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { nounwind }++!llvm.module.flags = !{!0}+!llvm.ident = !{!1}++!0 = !{i32 1, !"wchar_size", i32 4}+!1 = !{!"clang version 10.0.0-4ubuntu1 "}+!2 = !{i32 265}
+ disasm-test/tests/cmpxchg.ll view
@@ -0,0 +1,73 @@+; ModuleID = '/tmp/nix-shell.mXmHgC/cmpxchg1066927-8.bc'+source_filename = "disasm-test/tests/cmpxchg.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++@val = global i32 2344, align 4, !dbg !0++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define i32 @do_atomic_update(i32 %0) #0 !dbg !15 {+ %2 = alloca i32, align 4+ %3 = alloca i32, align 4+ %4 = alloca i32, align 4+ %5 = alloca i8, align 1+ store i32 %0, i32* %2, align 4+ call void @llvm.dbg.declare(metadata i32* %2, metadata !18, metadata !DIExpression()), !dbg !19+ call void @llvm.dbg.declare(metadata i32* %3, metadata !20, metadata !DIExpression()), !dbg !21+ store i32 2344, i32* %3, align 4, !dbg !21+ %6 = load atomic i32, i32* %2 seq_cst, align 4, !dbg !22+ store i32 %6, i32* %4, align 4, !dbg !22+ %7 = load i32, i32* %3, align 4, !dbg !22+ %8 = load i32, i32* %4, align 4, !dbg !22+ %9 = cmpxchg weak i32* @val, i32 %7, i32 %8 seq_cst seq_cst, !dbg !22+ %10 = extractvalue { i32, i1 } %9, 0, !dbg !22+ %11 = extractvalue { i32, i1 } %9, 1, !dbg !22+ br i1 %11, label %13, label %12, !dbg !22++12: ; preds = %1+ store i32 %10, i32* %3, align 4, !dbg !22+ br label %13, !dbg !22++13: ; preds = %12, %1+ %14 = zext i1 %11 to i8, !dbg !22+ store i8 %14, i8* %5, align 1, !dbg !22+ %15 = load i8, i8* %5, align 1, !dbg !22+ %16 = trunc i8 %15 to i1, !dbg !22+ %17 = zext i1 %16 to i32, !dbg !22+ ret i32 %17, !dbg !23+}++; Function Attrs: nounwind readnone speculatable willreturn+declare void @llvm.dbg.declare(metadata, metadata, metadata) #1++attributes #0 = { noinline nounwind optnone sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="true" "stack-protector-buffer-size"="4" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { nounwind readnone speculatable willreturn }++!llvm.dbg.cu = !{!2}+!llvm.module.flags = !{!10, !11, !12, !13}+!llvm.ident = !{!14}++!0 = !DIGlobalVariableExpression(var: !1, expr: !DIExpression())+!1 = distinct !DIGlobalVariable(name: "val", scope: !2, file: !3, line: 4, type: !6, isLocal: false, isDefinition: true)+!2 = distinct !DICompileUnit(language: DW_LANG_C99, file: !3, producer: "clang version 11.1.0", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !4, globals: !5, splitDebugInlining: false, nameTableKind: None)+!3 = !DIFile(filename: "disasm-test/tests/cmpxchg.c", directory: "/home/kquick/work/DFAMS/llvm-pretty-bc-parser")+!4 = !{}+!5 = !{!0}+!6 = !DIDerivedType(tag: DW_TAG_typedef, name: "atomic_int", file: !7, line: 83, baseType: !8)+!7 = !DIFile(filename: "/nix/store/4pk431ywfvw0k926blzwncnp699z3vh5-clang-wrapper-11.1.0/resource-root/include/stdatomic.h", directory: "")+!8 = !DIDerivedType(tag: DW_TAG_atomic_type, baseType: !9)+!9 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!10 = !{i32 7, !"Dwarf Version", i32 4}+!11 = !{i32 2, !"Debug Info Version", i32 3}+!12 = !{i32 1, !"wchar_size", i32 4}+!13 = !{i32 7, !"PIC Level", i32 2}+!14 = !{!"clang version 11.1.0"}+!15 = distinct !DISubprogram(name: "do_atomic_update", scope: !3, file: !3, line: 6, type: !16, scopeLine: 6, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !2, retainedNodes: !4)+!16 = !DISubroutineType(types: !17)+!17 = !{!9, !6}+!18 = !DILocalVariable(name: "newval", arg: 1, scope: !15, file: !3, line: 6, type: !6)+!19 = !DILocation(line: 6, column: 33, scope: !15)+!20 = !DILocalVariable(name: "old_val", scope: !15, file: !3, line: 7, type: !9)+!21 = !DILocation(line: 7, column: 9, scope: !15)+!22 = !DILocation(line: 8, column: 12, scope: !15)+!23 = !DILocation(line: 8, column: 5, scope: !15)
− disasm-test/tests/debug-loc.ll
@@ -1,43 +0,0 @@-; ModuleID = 'test.c'-target datalayout = "e-m:o-i64:64-f80:128-n8:16:32:64-S128"-target triple = "x86_64-apple-macosx10.10.0"--; Function Attrs: nounwind ssp uwtable-define i32 @f(i32 %c) #0 {-entry:- %c.addr = alloca i32, align 4- store i32 %c, i32* %c.addr, align 4- call void @llvm.dbg.declare(metadata i32* %c.addr, metadata !13, metadata !14), !dbg !15- %0 = load i32* %c.addr, align 4, !dbg !16- %add = add nsw i32 %0, 1, !dbg !16- ret i32 %add, !dbg !16-}--; Function Attrs: nounwind readnone-declare void @llvm.dbg.declare(metadata, metadata, metadata) #1--attributes #0 = { nounwind ssp uwtable "less-precise-fpmad"="false" "no-frame-pointer-elim"="true" "no-frame-pointer-elim-non-leaf" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "stack-protector-buffer-size"="8" "unsafe-fp-math"="false" "use-soft-float"="false" }-attributes #1 = { nounwind readnone }--!llvm.dbg.cu = !{!0}-!llvm.module.flags = !{!9, !10, !11}-!llvm.ident = !{!12}--!0 = !{!"0x11\0012\00clang version 3.6.1 (tags/RELEASE_361/final)\000\00\000\00\001", !1, !2, !2, !3, !2, !2} ; [ DW_TAG_compile_unit ] [/Users/trevor/Work/verifier/llvm-pretty-bc-parser/test.c] [DW_LANG_C99]-!1 = !{!"test.c", !"/Users/trevor/Work/verifier/llvm-pretty-bc-parser"}-!2 = !{}-!3 = !{!4}-!4 = !{!"0x2e\00f\00f\00\002\000\001\000\000\00256\000\002", !1, !5, !6, null, i32 (i32)* @f, null, null, !2} ; [ DW_TAG_subprogram ] [line 2] [def] [f]-!5 = !{!"0x29", !1} ; [ DW_TAG_file_type ] [/Users/trevor/Work/verifier/llvm-pretty-bc-parser/test.c]-!6 = !{!"0x15\00\000\000\000\000\000\000", null, null, null, !7, null, null, null} ; [ DW_TAG_subroutine_type ] [line 0, size 0, align 0, offset 0] [from ]-!7 = !{!8, !8}-!8 = !{!"0x24\00int\000\0032\0032\000\000\005", null, null} ; [ DW_TAG_base_type ] [int] [line 0, size 32, align 32, offset 0, enc DW_ATE_signed]-!9 = !{i32 2, !"Dwarf Version", i32 2}-!10 = !{i32 2, !"Debug Info Version", i32 2}-!11 = !{i32 1, !"PIC Level", i32 2}-!12 = !{!"clang version 3.6.1 (tags/RELEASE_361/final)"}-!13 = !{!"0x101\00c\0016777218\000", !4, !5, !8} ; [ DW_TAG_arg_variable ] [c] [line 2]-!14 = !{!"0x102"} ; [ DW_TAG_expression ]-!15 = !MDLocation(line: 2, column: 11, scope: !4)-!16 = !MDLocation(line: 3, column: 12, scope: !4)-!17 = !MDLocation(line: 3, column: 5, scope: !4)
+ disasm-test/tests/derivedtype.ll view
@@ -0,0 +1,52 @@+; ModuleID = 'derivedtype.bc'+source_filename = "derivedtype.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++%struct.message = type { i32, i8* }++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define i32 @foo(%struct.message* %0) #0 !dbg !8 {+ %2 = alloca %struct.message*, align 8+ store %struct.message* %0, %struct.message** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.message** %2, metadata !19, metadata !DIExpression()), !dbg !20+ %3 = load %struct.message*, %struct.message** %2, align 8, !dbg !21+ %4 = getelementptr inbounds %struct.message, %struct.message* %3, i32 0, i32 0, !dbg !22+ %5 = load i32, i32* %4, align 8, !dbg !22+ ret i32 %5, !dbg !23+}++; Function Attrs: nounwind readnone speculatable willreturn+declare void @llvm.dbg.declare(metadata, metadata, metadata) #1++attributes #0 = { noinline nounwind optnone sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="4" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { nounwind readnone speculatable willreturn }++!llvm.dbg.cu = !{!0}+!llvm.module.flags = !{!3, !4, !5, !6}+!llvm.ident = !{!7}++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 10.0.1 ", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "derivedtype.c", directory: "/home/kquick/work/RISE/llvm-regr5/disasm-test/tests")+!2 = !{}+!3 = !{i32 7, !"Dwarf Version", i32 4}+!4 = !{i32 2, !"Debug Info Version", i32 3}+!5 = !{i32 1, !"wchar_size", i32 4}+!6 = !{i32 7, !"PIC Level", i32 2}+!7 = !{!"clang version 10.0.1 "}+!8 = distinct !DISubprogram(name: "foo", scope: !1, file: !1, line: 3, type: !9, scopeLine: 3, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!9 = !DISubroutineType(types: !10)+!10 = !{!11, !12}+!11 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!12 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !13, size: 64)+!13 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "message", file: !1, line: 1, size: 128, elements: !14)+!14 = !{!15, !16}+!15 = !DIDerivedType(tag: DW_TAG_member, name: "msglen", scope: !13, file: !1, line: 1, baseType: !11, size: 32)+!16 = !DIDerivedType(tag: DW_TAG_member, name: "msgptr", scope: !13, file: !1, line: 1, baseType: !17, size: 64, offset: 64)+!17 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !18, size: 64)+!18 = !DIBasicType(name: "char", size: 8, encoding: DW_ATE_signed_char)+!19 = !DILocalVariable(name: "mptr", arg: 1, scope: !8, file: !1, line: 3, type: !12)+!20 = !DILocation(line: 3, column: 25, scope: !8)+!21 = !DILocation(line: 4, column: 12, scope: !8)+!22 = !DILocation(line: 4, column: 18, scope: !8)+!23 = !DILocation(line: 4, column: 5, scope: !8)
+ disasm-test/tests/di-arg-list.ll view
@@ -0,0 +1,43 @@+; ModuleID = 'di-arg-list.c'+source_filename = "di-arg-list.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++; Function Attrs: mustprogress nofree norecurse nosync nounwind readnone uwtable willreturn+define dso_local i32 @f(i32 %0, i32 %1) local_unnamed_addr #0 !dbg !9 {+ call void @llvm.dbg.value(metadata i32 %0, metadata !14, metadata !DIExpression()), !dbg !17+ call void @llvm.dbg.value(metadata i32 %1, metadata !15, metadata !DIExpression()), !dbg !17+ call void @llvm.dbg.value(metadata !DIArgList(i32 %0, i32 %1), metadata !16, metadata !DIExpression(DW_OP_LLVM_arg, 0, DW_OP_LLVM_arg, 1, DW_OP_plus, DW_OP_stack_value)), !dbg !17+ ret i32 0, !dbg !18+}++; Function Attrs: nofree nosync nounwind readnone speculatable willreturn+declare void @llvm.dbg.value(metadata, metadata, metadata) #1++attributes #0 = { mustprogress nofree norecurse nosync nounwind readnone uwtable willreturn "frame-pointer"="none" "min-legal-vector-width"="0" "no-trapping-math"="true" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "tune-cpu"="generic" }+attributes #1 = { nofree nosync nounwind readnone speculatable willreturn }++!llvm.dbg.cu = !{!0}+!llvm.module.flags = !{!3, !4, !5, !6}+!llvm.ident = !{!7}+!llvm.commandline = !{!8}++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 13.0.1", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "di-arg-list.c", directory: "/home/rscott/Documents/Hacking/Haskell/llvm-pretty-bc-parser/disasm-test/tests")+!2 = !{}+!3 = !{i32 7, !"Dwarf Version", i32 4}+!4 = !{i32 2, !"Debug Info Version", i32 3}+!5 = !{i32 1, !"wchar_size", i32 4}+!6 = !{i32 7, !"uwtable", i32 1}+!7 = !{!"clang version 13.0.1"}+!8 = !{!"/home/rscott/Software/clang+llvm-13.0.1/bin/clang-13 -S -emit-llvm -g -O1 -frecord-command-line di-arg-list.c -o di-arg-list.at-least-llvm13.ll"}+!9 = distinct !DISubprogram(name: "f", scope: !1, file: !1, line: 1, type: !10, scopeLine: 1, flags: DIFlagPrototyped | DIFlagAllCallsDescribed, spFlags: DISPFlagDefinition | DISPFlagOptimized, unit: !0, retainedNodes: !13)+!10 = !DISubroutineType(types: !11)+!11 = !{!12, !12, !12}+!12 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!13 = !{!14, !15, !16}+!14 = !DILocalVariable(name: "x", arg: 1, scope: !9, file: !1, line: 1, type: !12)+!15 = !DILocalVariable(name: "y", arg: 2, scope: !9, file: !1, line: 1, type: !12)+!16 = !DILocalVariable(name: "z", scope: !9, file: !1, line: 2, type: !12)+!17 = !DILocation(line: 0, scope: !9)+!18 = !DILocation(line: 3, column: 3, scope: !9)
+ disasm-test/tests/di-arg-list.pre-llvm13.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/diderivedtype-address-space.at-least-llvm14.ll view
@@ -0,0 +1,4 @@+;; Adapted from https://github.com/llvm/llvm-project/blob/d5561e0a0bbd484da17d3b68ae5fedc0a057246b/llvm/test/Assembler/debug-info.ll++!7 = !DIBasicType(tag: DW_TAG_base_type, name: "name", size: 1, align: 2, encoding: DW_ATE_unsigned_char)+!15 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !7, size: 32, align: 32, dwarfAddressSpace: 1)
+ disasm-test/tests/dilocalvariable.ll view
@@ -0,0 +1,32 @@+;; Adapted from https://github.com/llvm/llvm-project/blob/2ede126b1b3fae52cddece5cf1f75b474a9c7932/llvm/test/Assembler/dilocalvariable.ll++; CHECK: !named = !{!0, !1, !2, !3, !4, !5, !6, !7, !8, !9}+!named = !{!0, !1, !2, !3, !4, !5, !6, !7, !8, !9}++!llvm.module.flags = !{!10}+!llvm.dbg.cu = !{!1}++!0 = distinct !DISubprogram(unit: !1)+!1 = distinct !DICompileUnit(language: DW_LANG_C99, producer: "clang",+ file: !2,+ isOptimized: true, flags: "-O2",+ splitDebugFilename: "abc.debug", emissionKind: 2)+!2 = !DIFile(filename: "path/to/file", directory: "/path/to/dir")+!3 = !DIBasicType(name: "int", size: 32, align: 32, encoding: DW_ATE_signed)+!4 = !DILocation(scope: !0)++; CHECK: !5 = !DILocalVariable(name: "foo", arg: 3, scope: !0, file: !2, line: 7, type: !3, flags: DIFlagArtificial, align: 32)+; CHECK: !6 = !DILocalVariable(name: "foo", scope: !0, file: !2, line: 7, type: !3, flags: DIFlagArtificial)+!5 = !DILocalVariable(name: "foo", arg: 3,+ scope: !0, file: !2, line: 7, type: !3,+ flags: DIFlagArtificial, align: 32)+!6 = !DILocalVariable(name: "foo", scope: !0,+ file: !2, line: 7, type: !3, flags: DIFlagArtificial)++; CHECK: !7 = !DILocalVariable(arg: 1, scope: !0)+; CHECK: !8 = !DILocalVariable(scope: !0)+!7 = !DILocalVariable(scope: !0, arg: 1)+!8 = !DILocalVariable(scope: !0)+!9 = distinct !{}++!10 = !{i32 2, !"Debug Info Version", i32 3}
+ disasm-test/tests/dilocalvariable.pre-llvm14.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
+ disasm-test/tests/fcmp-fast-math.ll view
@@ -0,0 +1,23 @@+; ModuleID = 'test.c'+source_filename = "test.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-pc-linux-gnu"++; Function Attrs: norecurse nounwind readnone uwtable+define dso_local double @f(double %a) local_unnamed_addr #0 {+entry:+ %tobool = fcmp fast une double %a, 0.000000e+00+ %inc = fadd fast double %a, 1.000000e+00+ %a.addr.0 = select i1 %tobool, double %inc, double %a+ ret double %a.addr.0+}++attributes #0 = { norecurse nounwind readnone uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="none" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="true" "no-jump-tables"="false" "no-nans-fp-math"="true" "no-signed-zeros-fp-math"="true" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="true" "use-soft-float"="false" }++!llvm.module.flags = !{!0}+!llvm.ident = !{!1}+!llvm.commandline = !{!2}++!0 = !{i32 1, !"wchar_size", i32 4}+!1 = !{!"clang version 10.0.0-4ubuntu1 "}+!2 = !{!"/usr/lib/llvm-10/bin/clang -O3 test.c -emit-llvm -S -fno-discard-value-names -frecord-command-line -ffast-math"}
+ disasm-test/tests/fneg.ll view
@@ -0,0 +1,14 @@+define double @real_fneg(double %X) {+ %Y = fneg double %X ; <double> [#uses=1]+ ret double %Y+}++define double @real_fneg_constant() {+ %Y = fneg double -2.0 ; <double> [#uses=1]+ ret double %Y+}++define float @real_fnegf(float %X) {+ %Y = fneg float %X ; <float> [#uses=1]+ ret float %Y+}
− disasm-test/tests/global-alias.ll
@@ -1,10 +0,0 @@--%azaz = type { i32, i8 }--define i32 @f() {- %a = alloca %azaz, align 4- %ptr = getelementptr %azaz* %a, i32 0, i32 0- store i32 42, i32* %ptr- %x = load i32* %ptr- ret i32 %x-}
+ disasm-test/tests/global-var-extern.ll view
@@ -0,0 +1,32 @@+; ModuleID = '/tmp/nix-shell.AkHqe1/global-var-extern207140-4.bc'+source_filename = "disasm-test/tests/global-var-extern.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu-"++@global_var = external global i32, align 4++define i32 @foo() !dbg !9 {+ %1 = load i32, i32* @global_var, align 4, !dbg !14+ ret i32 %1, !dbg !15+}++!llvm.dbg.cu = !{!0}+!llvm.ident = !{!2}+!llvm.module.flags = !{!3, !4, !5, !6, !7, !8}++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 15.0.7", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "disasm-test/tests/global-var-extern.c", directory: "/home/kquick/work/RISE/llvm-regr5")+!2 = !{!"clang version 15.0.7"}+!3 = !{i32 7, !"Dwarf Version", i32 5}+!4 = !{i32 2, !"Debug Info Version", i32 3}+!5 = !{i32 1, !"wchar_size", i32 4}+!6 = !{i32 7, !"PIC Level", i32 2}+!7 = !{i32 7, !"uwtable", i32 2}+!8 = !{i32 7, !"frame-pointer", i32 2}+!9 = distinct !DISubprogram(name: "foo", scope: !1, file: !1, line: 3, type: !10, scopeLine: 3, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !13)+!10 = distinct !DISubroutineType(types: !11)+!11 = !{!12}+!12 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!13 = !{}+!14 = !DILocation(line: 3, column: 24, scope: !9)+!15 = !DILocation(line: 3, column: 17, scope: !9)
+ disasm-test/tests/global-var.ll view
@@ -0,0 +1,13 @@+; ModuleID = 'global-var.bc'+source_filename = "disasm-test/tests/global-var.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++@global_var = global i32 0, align 4++!llvm.module.flags = !{!0, !1}+!llvm.ident = !{!2}++!0 = !{i32 1, !"wchar_size", i32 4}+!1 = !{i32 7, !"PIC Level", i32 2}+!2 = !{!"clang version 11.1.0"}
− disasm-test/tests/global.ll
@@ -1,1 +0,0 @@-@value = global i32 10
+ disasm-test/tests/instrmd.ll view
@@ -0,0 +1,33 @@+define i32 @f(i32 %a0) {+ %1 = mul i32 %a0, 2+ %2 = mul i32 %1, 2+ %3 = mul i32 %2, 2+ br label %test+test:+ %4 = mul i32 %a0, 2, !llvm.loop !3+ br label %5, !dbg !1+; <label>:5+ %6 = mul i32 %4, 2+ %7 = mul i32 %6, 2+ %8 = mul i32 %7, 2+ %9 = mul i32 %8, 2+ %10 = mul i32 %9, 2+ %11 = mul i32 %10, 2+ %12 = mul i32 %11, 2+ br label %test, !dbg !2, !llvm.loop !3+}++!llvm.dbg.cu = !{!0}+!llvm.module.flags = !{!11}++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !7, producer: "hand-made version 1.0", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !10, splitDebugInlining: false, nameTableKind: None)+!1 = !DILocation(line: 1, column: 1, scope: !5)+!2 = !DILocation(line: 91, column: 81, scope: !5)+!3 = distinct !{!3, !1, !4}+!4 = !DILocation(line: 9, column: 8, scope: !5)+!5 = distinct !DILexicalBlock(scope: !6, file: !1, line: 32, column: 5)+!6 = distinct !DISubprogram(name: "test", scope: !7, file: !7, line: 31, type: !9, scopeLine: 31, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !10)+!7 = !DIFile(filename: "disasm-test/tests/instrmd.ll", directory: "/where/these/tests/are")+!9 = !DISubroutineType(types: !10)+!10 = !{}+!11 = !{i32 2, !"Debug Info Version", i32 3}
− disasm-test/tests/metadata.ll
@@ -1,10 +0,0 @@--; Some unnamed metadata nodes, which are referenced by the named metadata.-!0 = !{ !"zero" }-!1 = !{ !{ !"three" }, !2 }-!2 = !{ !"one" }--; A named metadata.-!thinger = !{ !0, !1, !2 }--@val = global i32 10
+ disasm-test/tests/opaque-atomicrmw.ll view
@@ -0,0 +1,4 @@+define void @atomicrmw(ptr %a, i32 %i) {+ %b = atomicrmw add ptr %a, i32 %i acquire+ ret void+}
+ disasm-test/tests/opaque-atomicrmw.pre-llvm15.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case requires the use of opaque pointers, which are most easily+usable with LLVM 15 or later.
+ disasm-test/tests/opaque-call.ll view
@@ -0,0 +1,11 @@+define void @f(i32 %x) {+ ret void+}++define void @g() {+ %p = alloca ptr+ store ptr @f, ptr %p+ %f = load ptr, ptr %p+ call void (i32) %f(i32 42)+ ret void+}
+ disasm-test/tests/opaque-call.pre-llvm15.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case requires the use of opaque pointers, which are most easily+usable with LLVM 15 or later.
+ disasm-test/tests/opaque-constant-getelementptr.ll view
@@ -0,0 +1,9 @@+%struct.RT = type { i8, [10 x [20 x i32]], i8 }+%struct.ST = type { i32, double, %struct.RT }++@.s = private constant %struct.ST zeroinitializer++define ptr @foo() {+entry:+ ret ptr getelementptr inbounds (%struct.ST, ptr @.s, i64 1, i32 2, i32 1, i64 5, i64 13)+}
+ disasm-test/tests/opaque-constant-getelementptr.pre-llvm15.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case requires the use of opaque pointers, which are most easily+usable with LLVM 15 or later.
+ disasm-test/tests/opaque-getelementptr.ll view
@@ -0,0 +1,8 @@+%struct.RT = type { i8, [10 x [20 x i32]], i8 }+%struct.ST = type { i32, double, %struct.RT }++define ptr @foo(ptr %s) {+entry:+ %arrayidx = getelementptr inbounds %struct.ST, ptr %s, i64 1, i32 2, i32 1, i64 5, i64 13+ ret ptr %arrayidx+}
+ disasm-test/tests/opaque-getelementptr.pre-llvm15.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case requires the use of opaque pointers, which are most easily+usable with LLVM 15 or later.
+ disasm-test/tests/p0.ll view
@@ -0,0 +1,533 @@+; ModuleID = 'p0.bc'+source_filename = "disasm-test/tests/p0.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++%struct.broker = type { [10 x %struct.message], i8, i8 }+%struct.message = type { i16, i8*, i8 }++@broker = external global %struct.broker, align 8+@signal = external global [200 x i8], align 16+@__const.main.msg = private unnamed_addr constant %struct.message { i16 0, i8* getelementptr inbounds ([200 x i8], [200 x i8]* @signal, i32 0, i32 0), i8 -56 }, align 8++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @broker_init(%struct.broker* %0) #0 !dbg !21 {+ %2 = alloca %struct.broker*, align 8+ store %struct.broker* %0, %struct.broker** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.broker** %2, metadata !44, metadata !DIExpression()), !dbg !45+ %3 = load %struct.broker*, %struct.broker** %2, align 8, !dbg !46+ %4 = getelementptr inbounds %struct.broker, %struct.broker* %3, i32 0, i32 2, !dbg !47+ store i8 0, i8* %4, align 1, !dbg !48+ ret void, !dbg !49+}++; Function Attrs: nounwind readnone speculatable willreturn+declare void @llvm.dbg.declare(metadata, metadata, metadata) #1++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @broker_run(%struct.broker* %0) #0 !dbg !50 {+ %2 = alloca %struct.broker*, align 8+ %3 = alloca i8, align 1+ store %struct.broker* %0, %struct.broker** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.broker** %2, metadata !51, metadata !DIExpression()), !dbg !52+ call void @llvm.dbg.declare(metadata i8* %3, metadata !53, metadata !DIExpression()), !dbg !55+ store i8 0, i8* %3, align 1, !dbg !55+ br label %4, !dbg !56++4: ; preds = %18, %1+ %5 = load i8, i8* %3, align 1, !dbg !57+ %6 = zext i8 %5 to i32, !dbg !57+ %7 = load %struct.broker*, %struct.broker** %2, align 8, !dbg !59+ %8 = getelementptr inbounds %struct.broker, %struct.broker* %7, i32 0, i32 2, !dbg !60+ %9 = load i8, i8* %8, align 1, !dbg !60+ %10 = zext i8 %9 to i32, !dbg !59+ %11 = icmp slt i32 %6, %10, !dbg !61+ br i1 %11, label %12, label %21, !dbg !62++12: ; preds = %4+ %13 = load %struct.broker*, %struct.broker** %2, align 8, !dbg !63+ %14 = getelementptr inbounds %struct.broker, %struct.broker* %13, i32 0, i32 0, !dbg !65+ %15 = load i8, i8* %3, align 1, !dbg !66+ %16 = zext i8 %15 to i64, !dbg !63+ %17 = getelementptr [10 x %struct.message], [10 x %struct.message]* %14, i64 0, i64 %16, !dbg !63+ call void @sp_receive(%struct.message* %17), !dbg !67+ br label %18, !dbg !68++18: ; preds = %12+ %19 = load i8, i8* %3, align 1, !dbg !69+ %20 = add i8 %19, 1, !dbg !69+ store i8 %20, i8* %3, align 1, !dbg !69+ br label %4, !dbg !70, !llvm.loop !71++21: ; preds = %4+ ret void, !dbg !73+}++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @sp_receive(%struct.message* %0) #0 !dbg !74 {+ %2 = alloca %struct.message*, align 8+ store %struct.message* %0, %struct.message** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.message** %2, metadata !78, metadata !DIExpression()), !dbg !79+ %3 = load %struct.message*, %struct.message** %2, align 8, !dbg !80+ %4 = getelementptr inbounds %struct.message, %struct.message* %3, i32 0, i32 0, !dbg !81+ %5 = load i16, i16* %4, align 8, !dbg !81+ %6 = zext i16 %5 to i32, !dbg !80+ switch i32 %6, label %28 [+ i32 0, label %7+ i32 1, label %14+ i32 2, label %21+ ], !dbg !82++7: ; preds = %1+ %8 = load %struct.message*, %struct.message** %2, align 8, !dbg !83+ %9 = getelementptr inbounds %struct.message, %struct.message* %8, i32 0, i32 1, !dbg !85+ %10 = load i8*, i8** %9, align 8, !dbg !85+ %11 = load %struct.message*, %struct.message** %2, align 8, !dbg !86+ %12 = getelementptr inbounds %struct.message, %struct.message* %11, i32 0, i32 2, !dbg !87+ %13 = load i8, i8* %12, align 8, !dbg !87+ call void @sp_clear(i8* %10, i8 zeroext %13), !dbg !88+ br label %29, !dbg !89++14: ; preds = %1+ %15 = load %struct.message*, %struct.message** %2, align 8, !dbg !90+ %16 = getelementptr inbounds %struct.message, %struct.message* %15, i32 0, i32 1, !dbg !91+ %17 = load i8*, i8** %16, align 8, !dbg !91+ %18 = load %struct.message*, %struct.message** %2, align 8, !dbg !92+ %19 = getelementptr inbounds %struct.message, %struct.message* %18, i32 0, i32 2, !dbg !93+ %20 = load i8, i8* %19, align 8, !dbg !93+ call void @sp_add_five(i8* %17, i8 zeroext %20), !dbg !94+ br label %29, !dbg !95++21: ; preds = %1+ %22 = load %struct.message*, %struct.message** %2, align 8, !dbg !96+ %23 = getelementptr inbounds %struct.message, %struct.message* %22, i32 0, i32 1, !dbg !97+ %24 = load i8*, i8** %23, align 8, !dbg !97+ %25 = load %struct.message*, %struct.message** %2, align 8, !dbg !98+ %26 = getelementptr inbounds %struct.message, %struct.message* %25, i32 0, i32 2, !dbg !99+ %27 = load i8, i8* %26, align 8, !dbg !99+ call void @sp_double(i8* %24, i8 zeroext %27), !dbg !100+ br label %29, !dbg !101++28: ; preds = %1+ br label %29, !dbg !102++29: ; preds = %28, %21, %14, %7+ ret void, !dbg !103+}++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @broker_publish(%struct.broker* %0, %struct.message* %1) #0 !dbg !104 {+ %3 = alloca %struct.broker*, align 8+ %4 = alloca %struct.message*, align 8+ store %struct.broker* %0, %struct.broker** %3, align 8+ call void @llvm.dbg.declare(metadata %struct.broker** %3, metadata !107, metadata !DIExpression()), !dbg !108+ store %struct.message* %1, %struct.message** %4, align 8+ call void @llvm.dbg.declare(metadata %struct.message** %4, metadata !109, metadata !DIExpression()), !dbg !110+ %5 = load %struct.broker*, %struct.broker** %3, align 8, !dbg !111+ %6 = getelementptr inbounds %struct.broker, %struct.broker* %5, i32 0, i32 0, !dbg !112+ %7 = load %struct.broker*, %struct.broker** %3, align 8, !dbg !113+ %8 = getelementptr inbounds %struct.broker, %struct.broker* %7, i32 0, i32 2, !dbg !114+ %9 = load i8, i8* %8, align 1, !dbg !115+ %10 = add i8 %9, 1, !dbg !115+ store i8 %10, i8* %8, align 1, !dbg !115+ %11 = zext i8 %9 to i64, !dbg !111+ %12 = getelementptr [10 x %struct.message], [10 x %struct.message]* %6, i64 0, i64 %11, !dbg !111+ %13 = load %struct.message*, %struct.message** %4, align 8, !dbg !116+ %14 = bitcast %struct.message* %12 to i8*, !dbg !117+ %15 = bitcast %struct.message* %13 to i8*, !dbg !117+ call void @llvm.memcpy.p0i8.p0i8.i64(i8* align 8 %14, i8* align 8 %15, i64 24, i1 false), !dbg !117+ ret void, !dbg !118+}++; Function Attrs: argmemonly nounwind willreturn+declare void @llvm.memcpy.p0i8.p0i8.i64(i8* noalias nocapture writeonly, i8* noalias nocapture readonly, i64, i1 immarg) #2++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @sp_clear(i8* %0, i8 zeroext %1) #0 !dbg !119 {+ %3 = alloca i8*, align 8+ %4 = alloca i8, align 1+ %5 = alloca i8, align 1+ store i8* %0, i8** %3, align 8+ call void @llvm.dbg.declare(metadata i8** %3, metadata !122, metadata !DIExpression()), !dbg !123+ store i8 %1, i8* %4, align 1+ call void @llvm.dbg.declare(metadata i8* %4, metadata !124, metadata !DIExpression()), !dbg !125+ call void @llvm.dbg.declare(metadata i8* %5, metadata !126, metadata !DIExpression()), !dbg !128+ store i8 0, i8* %5, align 1, !dbg !128+ br label %6, !dbg !129++6: ; preds = %17, %2+ %7 = load i8, i8* %5, align 1, !dbg !130+ %8 = zext i8 %7 to i32, !dbg !130+ %9 = load i8, i8* %4, align 1, !dbg !132+ %10 = zext i8 %9 to i32, !dbg !132+ %11 = icmp slt i32 %8, %10, !dbg !133+ br i1 %11, label %12, label %20, !dbg !134++12: ; preds = %6+ %13 = load i8*, i8** %3, align 8, !dbg !135+ %14 = load i8, i8* %5, align 1, !dbg !137+ %15 = zext i8 %14 to i64, !dbg !135+ %16 = getelementptr i8, i8* %13, i64 %15, !dbg !135+ store i8 0, i8* %16, align 1, !dbg !138+ br label %17, !dbg !139++17: ; preds = %12+ %18 = load i8, i8* %5, align 1, !dbg !140+ %19 = add i8 %18, 1, !dbg !140+ store i8 %19, i8* %5, align 1, !dbg !140+ br label %6, !dbg !141, !llvm.loop !142++20: ; preds = %6+ ret void, !dbg !144+}++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @sp_double(i8* %0, i8 zeroext %1) #0 !dbg !145 {+ %3 = alloca i8*, align 8+ %4 = alloca i8, align 1+ %5 = alloca i8, align 1+ store i8* %0, i8** %3, align 8+ call void @llvm.dbg.declare(metadata i8** %3, metadata !146, metadata !DIExpression()), !dbg !147+ store i8 %1, i8* %4, align 1+ call void @llvm.dbg.declare(metadata i8* %4, metadata !148, metadata !DIExpression()), !dbg !149+ call void @llvm.dbg.declare(metadata i8* %5, metadata !150, metadata !DIExpression()), !dbg !152+ store i8 0, i8* %5, align 1, !dbg !152+ br label %6, !dbg !153++6: ; preds = %21, %2+ %7 = load i8, i8* %5, align 1, !dbg !154+ %8 = zext i8 %7 to i32, !dbg !154+ %9 = load i8, i8* %4, align 1, !dbg !156+ %10 = zext i8 %9 to i32, !dbg !156+ %11 = icmp slt i32 %8, %10, !dbg !157+ br i1 %11, label %12, label %24, !dbg !158++12: ; preds = %6+ %13 = load i8*, i8** %3, align 8, !dbg !159+ %14 = load i8, i8* %5, align 1, !dbg !161+ %15 = zext i8 %14 to i64, !dbg !159+ %16 = getelementptr i8, i8* %13, i64 %15, !dbg !159+ %17 = load i8, i8* %16, align 1, !dbg !162+ %18 = zext i8 %17 to i32, !dbg !162+ %19 = mul i32 %18, 2, !dbg !162+ %20 = trunc i32 %19 to i8, !dbg !162+ store i8 %20, i8* %16, align 1, !dbg !162+ br label %21, !dbg !163++21: ; preds = %12+ %22 = load i8, i8* %5, align 1, !dbg !164+ %23 = add i8 %22, 1, !dbg !164+ store i8 %23, i8* %5, align 1, !dbg !164+ br label %6, !dbg !165, !llvm.loop !166++24: ; preds = %6+ ret void, !dbg !168+}++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @sp_add_five(i8* %0, i8 zeroext %1) #0 !dbg !169 {+ %3 = alloca i8*, align 8+ %4 = alloca i8, align 1+ %5 = alloca i8, align 1+ store i8* %0, i8** %3, align 8+ call void @llvm.dbg.declare(metadata i8** %3, metadata !170, metadata !DIExpression()), !dbg !171+ store i8 %1, i8* %4, align 1+ call void @llvm.dbg.declare(metadata i8* %4, metadata !172, metadata !DIExpression()), !dbg !173+ call void @llvm.dbg.declare(metadata i8* %5, metadata !174, metadata !DIExpression()), !dbg !176+ store i8 0, i8* %5, align 1, !dbg !176+ br label %6, !dbg !177++6: ; preds = %21, %2+ %7 = load i8, i8* %5, align 1, !dbg !178+ %8 = zext i8 %7 to i32, !dbg !178+ %9 = load i8, i8* %4, align 1, !dbg !180+ %10 = zext i8 %9 to i32, !dbg !180+ %11 = icmp slt i32 %8, %10, !dbg !181+ br i1 %11, label %12, label %24, !dbg !182++12: ; preds = %6+ %13 = load i8*, i8** %3, align 8, !dbg !183+ %14 = load i8, i8* %5, align 1, !dbg !185+ %15 = zext i8 %14 to i64, !dbg !183+ %16 = getelementptr i8, i8* %13, i64 %15, !dbg !183+ %17 = load i8, i8* %16, align 1, !dbg !186+ %18 = zext i8 %17 to i32, !dbg !186+ %19 = add i32 %18, 5, !dbg !186+ %20 = trunc i32 %19 to i8, !dbg !186+ store i8 %20, i8* %16, align 1, !dbg !186+ br label %21, !dbg !187++21: ; preds = %12+ %22 = load i8, i8* %5, align 1, !dbg !188+ %23 = add i8 %22, 1, !dbg !188+ store i8 %23, i8* %5, align 1, !dbg !188+ br label %6, !dbg !189, !llvm.loop !190++24: ; preds = %6+ ret void, !dbg !192+}++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define void @sp_send(i8* %0) #0 !dbg !193 {+ %2 = alloca i8*, align 8+ %3 = alloca %struct.message, align 8+ store i8* %0, i8** %2, align 8+ call void @llvm.dbg.declare(metadata i8** %2, metadata !196, metadata !DIExpression()), !dbg !197+ call void @llvm.dbg.declare(metadata %struct.message* %3, metadata !198, metadata !DIExpression()), !dbg !199+ %4 = getelementptr inbounds %struct.message, %struct.message* %3, i32 0, i32 0, !dbg !200+ store i16 0, i16* %4, align 8, !dbg !200+ %5 = getelementptr inbounds %struct.message, %struct.message* %3, i32 0, i32 1, !dbg !200+ %6 = load i8*, i8** %2, align 8, !dbg !201+ store i8* %6, i8** %5, align 8, !dbg !200+ %7 = getelementptr inbounds %struct.message, %struct.message* %3, i32 0, i32 2, !dbg !200+ store i8 -56, i8* %7, align 8, !dbg !200+ call void @broker_publish(%struct.broker* @broker, %struct.message* %3), !dbg !202+ ret void, !dbg !203+}++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define i32 @main() #0 !dbg !204 {+ %1 = alloca %struct.message, align 8+ call void @broker_init(%struct.broker* @broker), !dbg !208+ call void @llvm.dbg.declare(metadata %struct.message* %1, metadata !209, metadata !DIExpression()), !dbg !210+ %2 = bitcast %struct.message* %1 to i8*, !dbg !210+ call void @llvm.memcpy.p0i8.p0i8.i64(i8* align 8 %2, i8* align 8 bitcast (%struct.message* @__const.main.msg to i8*), i64 24, i1 false), !dbg !210+ call void @broker_publish(%struct.broker* @broker, %struct.message* %1), !dbg !211+ %3 = getelementptr inbounds %struct.message, %struct.message* %1, i32 0, i32 0, !dbg !212+ store i16 1, i16* %3, align 8, !dbg !213+ call void @broker_publish(%struct.broker* @broker, %struct.message* %1), !dbg !214+ %4 = getelementptr inbounds %struct.message, %struct.message* %1, i32 0, i32 0, !dbg !215+ store i16 2, i16* %4, align 8, !dbg !216+ call void @broker_publish(%struct.broker* @broker, %struct.message* %1), !dbg !217+ call void @broker_run(%struct.broker* @broker), !dbg !218+ ret i32 0, !dbg !219+}++attributes #0 = { noinline nounwind optnone sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="true" "stack-protector-buffer-size"="4" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { nounwind readnone speculatable willreturn }+attributes #2 = { argmemonly nounwind willreturn }++!llvm.dbg.cu = !{!0}+!llvm.module.flags = !{!16, !17, !18, !19}+!llvm.ident = !{!20}++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 11.1.0", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, globals: !3, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "disasm-test/tests/p0.c", directory: "/home/kquick/work/RISE/llvm-regr2")+!2 = !{}+!3 = !{!4, !12, !14}+!4 = !DIGlobalVariableExpression(var: !5, expr: !DIExpression(DW_OP_constu, 0, DW_OP_stack_value))+!5 = distinct !DIGlobalVariable(name: "MSG_TYPE_CLEAR", scope: !0, file: !1, line: 7, type: !6, isLocal: true, isDefinition: true)+!6 = !DIDerivedType(tag: DW_TAG_const_type, baseType: !7)+!7 = !DIDerivedType(tag: DW_TAG_typedef, name: "uint16_t", file: !8, line: 25, baseType: !9)+!8 = !DIFile(filename: "/nix/store/rfw51dqr3qn7b6fjy8hmx6f0x3hfwbx6-glibc-2.37-8-dev/include/bits/stdint-uintn.h", directory: "")+!9 = !DIDerivedType(tag: DW_TAG_typedef, name: "__uint16_t", file: !10, line: 40, baseType: !11)+!10 = !DIFile(filename: "/nix/store/rfw51dqr3qn7b6fjy8hmx6f0x3hfwbx6-glibc-2.37-8-dev/include/bits/types.h", directory: "")+!11 = !DIBasicType(name: "unsigned short", size: 16, encoding: DW_ATE_unsigned)+!12 = !DIGlobalVariableExpression(var: !13, expr: !DIExpression(DW_OP_constu, 1, DW_OP_stack_value))+!13 = distinct !DIGlobalVariable(name: "MSG_TYPE_ADD_FIVE", scope: !0, file: !1, line: 8, type: !6, isLocal: true, isDefinition: true)+!14 = !DIGlobalVariableExpression(var: !15, expr: !DIExpression(DW_OP_constu, 2, DW_OP_stack_value))+!15 = distinct !DIGlobalVariable(name: "MSG_TYPE_DOUBLE", scope: !0, file: !1, line: 9, type: !6, isLocal: true, isDefinition: true)+!16 = !{i32 7, !"Dwarf Version", i32 4}+!17 = !{i32 2, !"Debug Info Version", i32 3}+!18 = !{i32 1, !"wchar_size", i32 4}+!19 = !{i32 7, !"PIC Level", i32 2}+!20 = !{!"clang version 11.1.0"}+!21 = distinct !DISubprogram(name: "broker_init", scope: !1, file: !1, line: 29, type: !22, scopeLine: 29, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!22 = !DISubroutineType(types: !23)+!23 = !{null, !24}+!24 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !25, size: 64)+!25 = !DIDerivedType(tag: DW_TAG_typedef, name: "broker_t", file: !1, line: 23, baseType: !26)+!26 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "broker", file: !1, line: 19, size: 1984, elements: !27)+!27 = !{!28, !42, !43}+!28 = !DIDerivedType(tag: DW_TAG_member, name: "msgs", scope: !26, file: !1, line: 20, baseType: !29, size: 1920)+!29 = !DICompositeType(tag: DW_TAG_array_type, baseType: !30, size: 1920, elements: !40)+!30 = !DIDerivedType(tag: DW_TAG_typedef, name: "message_t", file: !1, line: 17, baseType: !31)+!31 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "message", file: !1, line: 13, size: 192, elements: !32)+!32 = !{!33, !34, !39}+!33 = !DIDerivedType(tag: DW_TAG_member, name: "type", scope: !31, file: !1, line: 14, baseType: !7, size: 16)+!34 = !DIDerivedType(tag: DW_TAG_member, name: "payload", scope: !31, file: !1, line: 15, baseType: !35, size: 64, offset: 64)+!35 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !36, size: 64)+!36 = !DIDerivedType(tag: DW_TAG_typedef, name: "uint8_t", file: !8, line: 24, baseType: !37)+!37 = !DIDerivedType(tag: DW_TAG_typedef, name: "__uint8_t", file: !10, line: 38, baseType: !38)+!38 = !DIBasicType(name: "unsigned char", size: 8, encoding: DW_ATE_unsigned_char)+!39 = !DIDerivedType(tag: DW_TAG_member, name: "payload_len", scope: !31, file: !1, line: 16, baseType: !36, size: 8, offset: 128)+!40 = !{!41}+!41 = !DISubrange(count: 10)+!42 = !DIDerivedType(tag: DW_TAG_member, name: "msg_idx", scope: !26, file: !1, line: 21, baseType: !36, size: 8, offset: 1920)+!43 = !DIDerivedType(tag: DW_TAG_member, name: "num_messages", scope: !26, file: !1, line: 22, baseType: !36, size: 8, offset: 1928)+!44 = !DILocalVariable(name: "broker", arg: 1, scope: !21, file: !1, line: 29, type: !24)+!45 = !DILocation(line: 29, column: 29, scope: !21)+!46 = !DILocation(line: 30, column: 5, scope: !21)+!47 = !DILocation(line: 30, column: 13, scope: !21)+!48 = !DILocation(line: 30, column: 26, scope: !21)+!49 = !DILocation(line: 31, column: 1, scope: !21)+!50 = distinct !DISubprogram(name: "broker_run", scope: !1, file: !1, line: 33, type: !22, scopeLine: 33, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!51 = !DILocalVariable(name: "broker", arg: 1, scope: !50, file: !1, line: 33, type: !24)+!52 = !DILocation(line: 33, column: 28, scope: !50)+!53 = !DILocalVariable(name: "i", scope: !54, file: !1, line: 34, type: !36)+!54 = distinct !DILexicalBlock(scope: !50, file: !1, line: 34, column: 5)+!55 = !DILocation(line: 34, column: 18, scope: !54)+!56 = !DILocation(line: 34, column: 10, scope: !54)+!57 = !DILocation(line: 34, column: 25, scope: !58)+!58 = distinct !DILexicalBlock(scope: !54, file: !1, line: 34, column: 5)+!59 = !DILocation(line: 34, column: 29, scope: !58)+!60 = !DILocation(line: 34, column: 37, scope: !58)+!61 = !DILocation(line: 34, column: 27, scope: !58)+!62 = !DILocation(line: 34, column: 5, scope: !54)+!63 = !DILocation(line: 36, column: 22, scope: !64)+!64 = distinct !DILexicalBlock(scope: !58, file: !1, line: 34, column: 56)+!65 = !DILocation(line: 36, column: 30, scope: !64)+!66 = !DILocation(line: 36, column: 35, scope: !64)+!67 = !DILocation(line: 36, column: 9, scope: !64)+!68 = !DILocation(line: 37, column: 5, scope: !64)+!69 = !DILocation(line: 34, column: 52, scope: !58)+!70 = !DILocation(line: 34, column: 5, scope: !58)+!71 = distinct !{!71, !62, !72}+!72 = !DILocation(line: 37, column: 5, scope: !54)+!73 = !DILocation(line: 38, column: 1, scope: !50)+!74 = distinct !DISubprogram(name: "sp_receive", scope: !1, file: !1, line: 67, type: !75, scopeLine: 67, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!75 = !DISubroutineType(types: !76)+!76 = !{null, !77}+!77 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !30, size: 64)+!78 = !DILocalVariable(name: "msg", arg: 1, scope: !74, file: !1, line: 67, type: !77)+!79 = !DILocation(line: 67, column: 29, scope: !74)+!80 = !DILocation(line: 68, column: 13, scope: !74)+!81 = !DILocation(line: 68, column: 18, scope: !74)+!82 = !DILocation(line: 68, column: 5, scope: !74)+!83 = !DILocation(line: 70, column: 22, scope: !84)+!84 = distinct !DILexicalBlock(scope: !74, file: !1, line: 68, column: 24)+!85 = !DILocation(line: 70, column: 27, scope: !84)+!86 = !DILocation(line: 70, column: 36, scope: !84)+!87 = !DILocation(line: 70, column: 41, scope: !84)+!88 = !DILocation(line: 70, column: 13, scope: !84)+!89 = !DILocation(line: 71, column: 13, scope: !84)+!90 = !DILocation(line: 73, column: 25, scope: !84)+!91 = !DILocation(line: 73, column: 30, scope: !84)+!92 = !DILocation(line: 73, column: 39, scope: !84)+!93 = !DILocation(line: 73, column: 44, scope: !84)+!94 = !DILocation(line: 73, column: 13, scope: !84)+!95 = !DILocation(line: 74, column: 13, scope: !84)+!96 = !DILocation(line: 76, column: 23, scope: !84)+!97 = !DILocation(line: 76, column: 28, scope: !84)+!98 = !DILocation(line: 76, column: 37, scope: !84)+!99 = !DILocation(line: 76, column: 42, scope: !84)+!100 = !DILocation(line: 76, column: 13, scope: !84)+!101 = !DILocation(line: 77, column: 13, scope: !84)+!102 = !DILocation(line: 79, column: 13, scope: !84)+!103 = !DILocation(line: 81, column: 1, scope: !74)+!104 = distinct !DISubprogram(name: "broker_publish", scope: !1, file: !1, line: 40, type: !105, scopeLine: 40, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!105 = !DISubroutineType(types: !106)+!106 = !{null, !24, !77}+!107 = !DILocalVariable(name: "broker", arg: 1, scope: !104, file: !1, line: 40, type: !24)+!108 = !DILocation(line: 40, column: 32, scope: !104)+!109 = !DILocalVariable(name: "msg", arg: 2, scope: !104, file: !1, line: 40, type: !77)+!110 = !DILocation(line: 40, column: 52, scope: !104)+!111 = !DILocation(line: 41, column: 5, scope: !104)+!112 = !DILocation(line: 41, column: 13, scope: !104)+!113 = !DILocation(line: 41, column: 18, scope: !104)+!114 = !DILocation(line: 41, column: 26, scope: !104)+!115 = !DILocation(line: 41, column: 38, scope: !104)+!116 = !DILocation(line: 41, column: 45, scope: !104)+!117 = !DILocation(line: 41, column: 44, scope: !104)+!118 = !DILocation(line: 42, column: 1, scope: !104)+!119 = distinct !DISubprogram(name: "sp_clear", scope: !1, file: !1, line: 44, type: !120, scopeLine: 44, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!120 = !DISubroutineType(types: !121)+!121 = !{null, !35, !36}+!122 = !DILocalVariable(name: "signal", arg: 1, scope: !119, file: !1, line: 44, type: !35)+!123 = !DILocation(line: 44, column: 25, scope: !119)+!124 = !DILocalVariable(name: "signal_len", arg: 2, scope: !119, file: !1, line: 44, type: !36)+!125 = !DILocation(line: 44, column: 41, scope: !119)+!126 = !DILocalVariable(name: "i", scope: !127, file: !1, line: 45, type: !36)+!127 = distinct !DILexicalBlock(scope: !119, file: !1, line: 45, column: 5)+!128 = !DILocation(line: 45, column: 18, scope: !127)+!129 = !DILocation(line: 45, column: 10, scope: !127)+!130 = !DILocation(line: 45, column: 25, scope: !131)+!131 = distinct !DILexicalBlock(scope: !127, file: !1, line: 45, column: 5)+!132 = !DILocation(line: 45, column: 29, scope: !131)+!133 = !DILocation(line: 45, column: 27, scope: !131)+!134 = !DILocation(line: 45, column: 5, scope: !127)+!135 = !DILocation(line: 46, column: 9, scope: !136)+!136 = distinct !DILexicalBlock(scope: !131, file: !1, line: 45, column: 46)+!137 = !DILocation(line: 46, column: 16, scope: !136)+!138 = !DILocation(line: 46, column: 19, scope: !136)+!139 = !DILocation(line: 47, column: 5, scope: !136)+!140 = !DILocation(line: 45, column: 42, scope: !131)+!141 = !DILocation(line: 45, column: 5, scope: !131)+!142 = distinct !{!142, !134, !143}+!143 = !DILocation(line: 47, column: 5, scope: !127)+!144 = !DILocation(line: 48, column: 1, scope: !119)+!145 = distinct !DISubprogram(name: "sp_double", scope: !1, file: !1, line: 50, type: !120, scopeLine: 50, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!146 = !DILocalVariable(name: "signal", arg: 1, scope: !145, file: !1, line: 50, type: !35)+!147 = !DILocation(line: 50, column: 26, scope: !145)+!148 = !DILocalVariable(name: "signal_len", arg: 2, scope: !145, file: !1, line: 50, type: !36)+!149 = !DILocation(line: 50, column: 42, scope: !145)+!150 = !DILocalVariable(name: "i", scope: !151, file: !1, line: 51, type: !36)+!151 = distinct !DILexicalBlock(scope: !145, file: !1, line: 51, column: 5)+!152 = !DILocation(line: 51, column: 18, scope: !151)+!153 = !DILocation(line: 51, column: 10, scope: !151)+!154 = !DILocation(line: 51, column: 25, scope: !155)+!155 = distinct !DILexicalBlock(scope: !151, file: !1, line: 51, column: 5)+!156 = !DILocation(line: 51, column: 29, scope: !155)+!157 = !DILocation(line: 51, column: 27, scope: !155)+!158 = !DILocation(line: 51, column: 5, scope: !151)+!159 = !DILocation(line: 52, column: 9, scope: !160)+!160 = distinct !DILexicalBlock(scope: !155, file: !1, line: 51, column: 46)+!161 = !DILocation(line: 52, column: 16, scope: !160)+!162 = !DILocation(line: 52, column: 19, scope: !160)+!163 = !DILocation(line: 53, column: 5, scope: !160)+!164 = !DILocation(line: 51, column: 42, scope: !155)+!165 = !DILocation(line: 51, column: 5, scope: !155)+!166 = distinct !{!166, !158, !167}+!167 = !DILocation(line: 53, column: 5, scope: !151)+!168 = !DILocation(line: 54, column: 1, scope: !145)+!169 = distinct !DISubprogram(name: "sp_add_five", scope: !1, file: !1, line: 56, type: !120, scopeLine: 56, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!170 = !DILocalVariable(name: "signal", arg: 1, scope: !169, file: !1, line: 56, type: !35)+!171 = !DILocation(line: 56, column: 28, scope: !169)+!172 = !DILocalVariable(name: "signal_len", arg: 2, scope: !169, file: !1, line: 56, type: !36)+!173 = !DILocation(line: 56, column: 44, scope: !169)+!174 = !DILocalVariable(name: "i", scope: !175, file: !1, line: 57, type: !36)+!175 = distinct !DILexicalBlock(scope: !169, file: !1, line: 57, column: 5)+!176 = !DILocation(line: 57, column: 18, scope: !175)+!177 = !DILocation(line: 57, column: 10, scope: !175)+!178 = !DILocation(line: 57, column: 25, scope: !179)+!179 = distinct !DILexicalBlock(scope: !175, file: !1, line: 57, column: 5)+!180 = !DILocation(line: 57, column: 29, scope: !179)+!181 = !DILocation(line: 57, column: 27, scope: !179)+!182 = !DILocation(line: 57, column: 5, scope: !175)+!183 = !DILocation(line: 58, column: 9, scope: !184)+!184 = distinct !DILexicalBlock(scope: !179, file: !1, line: 57, column: 46)+!185 = !DILocation(line: 58, column: 16, scope: !184)+!186 = !DILocation(line: 58, column: 19, scope: !184)+!187 = !DILocation(line: 59, column: 5, scope: !184)+!188 = !DILocation(line: 57, column: 42, scope: !179)+!189 = !DILocation(line: 57, column: 5, scope: !179)+!190 = distinct !{!190, !182, !191}+!191 = !DILocation(line: 59, column: 5, scope: !175)+!192 = !DILocation(line: 60, column: 1, scope: !169)+!193 = distinct !DISubprogram(name: "sp_send", scope: !1, file: !1, line: 62, type: !194, scopeLine: 62, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!194 = !DISubroutineType(types: !195)+!195 = !{null, !35}+!196 = !DILocalVariable(name: "signal", arg: 1, scope: !193, file: !1, line: 62, type: !35)+!197 = !DILocation(line: 62, column: 24, scope: !193)+!198 = !DILocalVariable(name: "msg", scope: !193, file: !1, line: 63, type: !30)+!199 = !DILocation(line: 63, column: 15, scope: !193)+!200 = !DILocation(line: 63, column: 21, scope: !193)+!201 = !DILocation(line: 63, column: 38, scope: !193)+!202 = !DILocation(line: 64, column: 5, scope: !193)+!203 = !DILocation(line: 65, column: 1, scope: !193)+!204 = distinct !DISubprogram(name: "main", scope: !1, file: !1, line: 83, type: !205, scopeLine: 83, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!205 = !DISubroutineType(types: !206)+!206 = !{!207}+!207 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!208 = !DILocation(line: 84, column: 5, scope: !204)+!209 = !DILocalVariable(name: "msg", scope: !204, file: !1, line: 86, type: !30)+!210 = !DILocation(line: 86, column: 15, scope: !204)+!211 = !DILocation(line: 87, column: 5, scope: !204)+!212 = !DILocation(line: 88, column: 9, scope: !204)+!213 = !DILocation(line: 88, column: 14, scope: !204)+!214 = !DILocation(line: 89, column: 5, scope: !204)+!215 = !DILocation(line: 90, column: 9, scope: !204)+!216 = !DILocation(line: 90, column: 14, scope: !204)+!217 = !DILocation(line: 91, column: 5, scope: !204)+!218 = !DILocation(line: 93, column: 5, scope: !204)+!219 = !DILocation(line: 94, column: 1, scope: !204)
+ disasm-test/tests/poison.ll view
@@ -0,0 +1,3 @@+define double @f(i32 %x) {+ ret double poison+}
+ disasm-test/tests/poison.pre-llvm12.ll view
@@ -0,0 +1,1 @@+SKIP_TEST
− disasm-test/tests/printf_frexpl.ll
@@ -1,60 +0,0 @@-; ModuleID = 'lib/printf-frexpl.c' -target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128" -target triple = "x86_64-unknown-linux-gnu" - -; Function Attrs: nounwind uwtable -define x86_fp80 @printf_frexpl(x86_fp80 %x, i32* nocapture %expptr) #0 { - %exponent = alloca i32, align 4 - %_cw = alloca i16, align 2 - %_ncw = alloca i16, align 2 - %_ncw1 = alloca i16, align 2 - call void asm sideeffect "fnstcw $0", "=*m,~{dirflag},~{fpsr},~{flags}"(i16* %_cw) #2, !srcloc !1 - %1 = load i16* %_cw, align 2, !tbaa !2 - %2 = or i16 %1, 768 - store i16 %2, i16* %_ncw, align 2, !tbaa !2 - call void asm sideeffect "fldcw $0", "*m,~{dirflag},~{fpsr},~{flags}"(i16* %_ncw) #2, !srcloc !6 - %3 = call x86_fp80 @frexpl(x86_fp80 %x, i32* %exponent) #2 - %4 = fadd x86_fp80 %3, %3 - %5 = load i32* %exponent, align 4, !tbaa !7 - %6 = add nsw i32 %5, -1 - store i32 %6, i32* %exponent, align 4, !tbaa !7 - %7 = icmp slt i32 %5, -16381 - br i1 %7, label %8, label %11 - -; <label>:8 ; preds = %0 - %9 = add nsw i32 %5, 16381 - %10 = call x86_fp80 @ldexpl(x86_fp80 %4, i32 %9) #2 - store i32 -16382, i32* %exponent, align 4, !tbaa !7 - br label %11 - -; <label>:11 ; preds = %8, %0 - %12 = phi i32 [ -16382, %8 ], [ %6, %0 ] - %.0 = phi x86_fp80 [ %10, %8 ], [ %4, %0 ] - store i16 %1, i16* %_ncw1, align 2, !tbaa !2 - call void asm sideeffect "fldcw $0", "*m,~{dirflag},~{fpsr},~{flags}"(i16* %_ncw1) #2, !srcloc !9 - store i32 %12, i32* %expptr, align 4, !tbaa !7 - ret x86_fp80 %.0 -} - -; Function Attrs: nounwind -declare x86_fp80 @frexpl(x86_fp80, i32* nocapture) #1 - -; Function Attrs: nounwind -declare x86_fp80 @ldexpl(x86_fp80, i32) #1 - -attributes #0 = { nounwind uwtable "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "stack-protector-buffer-size"="8" "unsafe-fp-math"="false" "use-soft-float"="false" } -attributes #1 = { nounwind "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "stack-protector-buffer-size"="8" "unsafe-fp-math"="false" "use-soft-float"="false" } -attributes #2 = { nounwind } - -!llvm.ident = !{!0} - -!0 = !{!"clang version 3.6.2 (tags/RELEASE_362/final)"} -!1 = !{i32 -2146987380} -!2 = !{!3, !3, i64 0} -!3 = !{!"short", !4, i64 0} -!4 = !{!"omnipotent char", !5, i64 0} -!5 = !{!"Simple C/C++ TBAA"} -!6 = !{i32 -2146987172} -!7 = !{!8, !8, i64 0} -!8 = !{!"int", !4, i64 0} -!9 = !{i32 -2146986812}
+ disasm-test/tests/smallprog.ll view
@@ -0,0 +1,226 @@+; ModuleID = 'smallprog.c'+source_filename = "smallprog.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++%struct.message = type { i32, i32*, i32 }+%struct.broker = type { [5 x %struct.message], i32, i32 }++; Function Attrs: noinline nounwind optnone uwtable+define dso_local void @sp_receive(%struct.message* %0) #0 !dbg !8 {+ %2 = alloca %struct.message*, align 8+ %3 = alloca i32, align 4+ store %struct.message* %0, %struct.message** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.message** %2, metadata !20, metadata !DIExpression()), !dbg !21+ %4 = load %struct.message*, %struct.message** %2, align 8, !dbg !22+ %5 = getelementptr inbounds %struct.message, %struct.message* %4, i32 0, i32 0, !dbg !23+ %6 = load i32, i32* %5, align 8, !dbg !23+ switch i32 %6, label %26 [+ i32 0, label %7+ ], !dbg !24++7: ; preds = %1+ call void @llvm.dbg.declare(metadata i32* %3, metadata !25, metadata !DIExpression()), !dbg !28+ store i32 0, i32* %3, align 4, !dbg !28+ br label %8, !dbg !29++8: ; preds = %22, %7+ %9 = load i32, i32* %3, align 4, !dbg !30+ %10 = load %struct.message*, %struct.message** %2, align 8, !dbg !32+ %11 = getelementptr inbounds %struct.message, %struct.message* %10, i32 0, i32 2, !dbg !33+ %12 = load i32, i32* %11, align 8, !dbg !33+ %13 = shl i32 %9, %12, !dbg !34+ %14 = icmp ne i32 %13, 0, !dbg !35+ br i1 %14, label %15, label %25, !dbg !35++15: ; preds = %8+ %16 = load %struct.message*, %struct.message** %2, align 8, !dbg !36+ %17 = getelementptr inbounds %struct.message, %struct.message* %16, i32 0, i32 1, !dbg !38+ %18 = load i32*, i32** %17, align 8, !dbg !38+ %19 = load i32, i32* %3, align 4, !dbg !39+ %20 = sext i32 %19 to i64, !dbg !36+ %21 = getelementptr inbounds i32, i32* %18, i64 %20, !dbg !36+ store i32 0, i32* %21, align 4, !dbg !40+ br label %22, !dbg !41++22: ; preds = %15+ %23 = load i32, i32* %3, align 4, !dbg !42+ %24 = add nsw i32 %23, 1, !dbg !42+ store i32 %24, i32* %3, align 4, !dbg !42+ br label %8, !dbg !43, !llvm.loop !44++25: ; preds = %8+ br label %26, !dbg !47++26: ; preds = %1, %25+ ret void, !dbg !48+}++; Function Attrs: nofree nosync nounwind readnone speculatable willreturn+declare void @llvm.dbg.declare(metadata, metadata, metadata) #1++; Function Attrs: noinline nounwind optnone uwtable+define dso_local void @broker_init(%struct.broker* %0) #0 !dbg !49 {+ %2 = alloca %struct.broker*, align 8+ store %struct.broker* %0, %struct.broker** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.broker** %2, metadata !62, metadata !DIExpression()), !dbg !63+ %3 = load %struct.broker*, %struct.broker** %2, align 8, !dbg !64+ %4 = getelementptr inbounds %struct.broker, %struct.broker* %3, i32 0, i32 2, !dbg !65+ store i32 0, i32* %4, align 4, !dbg !66+ ret void, !dbg !67+}++; Function Attrs: noinline nounwind optnone uwtable+define dso_local void @broker_run(%struct.broker* %0) #0 !dbg !68 {+ %2 = alloca %struct.broker*, align 8+ %3 = alloca i32, align 4+ store %struct.broker* %0, %struct.broker** %2, align 8+ call void @llvm.dbg.declare(metadata %struct.broker** %2, metadata !69, metadata !DIExpression()), !dbg !70+ call void @llvm.dbg.declare(metadata i32* %3, metadata !71, metadata !DIExpression()), !dbg !73+ store i32 0, i32* %3, align 4, !dbg !73+ br label %4, !dbg !74++4: ; preds = %16, %1+ %5 = load i32, i32* %3, align 4, !dbg !75+ %6 = load %struct.broker*, %struct.broker** %2, align 8, !dbg !77+ %7 = getelementptr inbounds %struct.broker, %struct.broker* %6, i32 0, i32 2, !dbg !78+ %8 = load i32, i32* %7, align 4, !dbg !78+ %9 = icmp slt i32 %5, %8, !dbg !79+ br i1 %9, label %10, label %19, !dbg !80++10: ; preds = %4+ %11 = load %struct.broker*, %struct.broker** %2, align 8, !dbg !81+ %12 = getelementptr inbounds %struct.broker, %struct.broker* %11, i32 0, i32 0, !dbg !83+ %13 = load i32, i32* %3, align 4, !dbg !84+ %14 = sext i32 %13 to i64, !dbg !81+ %15 = getelementptr inbounds [5 x %struct.message], [5 x %struct.message]* %12, i64 0, i64 %14, !dbg !81+ call void @sp_receive(%struct.message* %15), !dbg !85+ br label %16, !dbg !86++16: ; preds = %10+ %17 = load i32, i32* %3, align 4, !dbg !87+ %18 = add nsw i32 %17, 1, !dbg !87+ store i32 %18, i32* %3, align 4, !dbg !87+ br label %4, !dbg !88, !llvm.loop !89++19: ; preds = %4+ ret void, !dbg !91+}++; Function Attrs: noinline nounwind optnone uwtable+define dso_local i32 @main() #0 !dbg !92 {+ %1 = alloca %struct.broker, align 8+ call void @llvm.dbg.declare(metadata %struct.broker* %1, metadata !95, metadata !DIExpression()), !dbg !96+ call void @broker_init(%struct.broker* %1), !dbg !97+ call void @broker_run(%struct.broker* %1), !dbg !98+ ret i32 0, !dbg !99+}++attributes #0 = { noinline nounwind optnone uwtable "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="true" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "tune-cpu"="generic" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { nofree nosync nounwind readnone speculatable willreturn }++!llvm.dbg.cu = !{!0}+!llvm.module.flags = !{!3, !4, !5}+!llvm.ident = !{!6}+!llvm.commandline = !{!7}++!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 12.0.1", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !2, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "smallprog.c", directory: "/home/rscott/Documents/Hacking/Haskell/llvm-pretty-bc-parser/disasm-test/tests")+!2 = !{}+!3 = !{i32 7, !"Dwarf Version", i32 4}+!4 = !{i32 2, !"Debug Info Version", i32 3}+!5 = !{i32 1, !"wchar_size", i32 4}+!6 = !{!"clang version 12.0.1"}+!7 = !{!"/home/rscott/Software/clang+llvm-12.0.1/bin/clang-12 -emit-llvm -g -S -frecord-command-line smallprog.c -o smallprog.ll"}+!8 = distinct !DISubprogram(name: "sp_receive", scope: !1, file: !1, line: 17, type: !9, scopeLine: 17, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!9 = !DISubroutineType(types: !10)+!10 = !{null, !11}+!11 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !12, size: 64)+!12 = !DIDerivedType(tag: DW_TAG_typedef, name: "message_t", file: !1, line: 9, baseType: !13)+!13 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "message", file: !1, line: 5, size: 192, elements: !14)+!14 = !{!15, !17, !19}+!15 = !DIDerivedType(tag: DW_TAG_member, name: "type", scope: !13, file: !1, line: 6, baseType: !16, size: 32)+!16 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!17 = !DIDerivedType(tag: DW_TAG_member, name: "payload", scope: !13, file: !1, line: 7, baseType: !18, size: 64, offset: 64)+!18 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !16, size: 64)+!19 = !DIDerivedType(tag: DW_TAG_member, name: "payload_len", scope: !13, file: !1, line: 8, baseType: !16, size: 32, offset: 128)+!20 = !DILocalVariable(name: "msg", arg: 1, scope: !8, file: !1, line: 17, type: !11)+!21 = !DILocation(line: 17, column: 28, scope: !8)+!22 = !DILocation(line: 18, column: 13, scope: !8)+!23 = !DILocation(line: 18, column: 18, scope: !8)+!24 = !DILocation(line: 18, column: 5, scope: !8)+!25 = !DILocalVariable(name: "i", scope: !26, file: !1, line: 20, type: !16)+!26 = distinct !DILexicalBlock(scope: !27, file: !1, line: 20, column: 9)+!27 = distinct !DILexicalBlock(scope: !8, file: !1, line: 18, column: 24)+!28 = !DILocation(line: 20, column: 18, scope: !26)+!29 = !DILocation(line: 20, column: 14, scope: !26)+!30 = !DILocation(line: 20, column: 25, scope: !31)+!31 = distinct !DILexicalBlock(scope: !26, file: !1, line: 20, column: 9)+!32 = !DILocation(line: 20, column: 30, scope: !31)+!33 = !DILocation(line: 20, column: 35, scope: !31)+!34 = !DILocation(line: 20, column: 27, scope: !31)+!35 = !DILocation(line: 20, column: 9, scope: !26)+!36 = !DILocation(line: 21, column: 13, scope: !37)+!37 = distinct !DILexicalBlock(scope: !31, file: !1, line: 20, column: 53)+!38 = !DILocation(line: 21, column: 18, scope: !37)+!39 = !DILocation(line: 21, column: 26, scope: !37)+!40 = !DILocation(line: 21, column: 29, scope: !37)+!41 = !DILocation(line: 22, column: 9, scope: !37)+!42 = !DILocation(line: 20, column: 48, scope: !31)+!43 = !DILocation(line: 20, column: 9, scope: !31)+!44 = distinct !{!44, !35, !45, !46}+!45 = !DILocation(line: 22, column: 9, scope: !26)+!46 = !{!"llvm.loop.mustprogress"}+!47 = !DILocation(line: 23, column: 9, scope: !27)+!48 = !DILocation(line: 25, column: 1, scope: !8)+!49 = distinct !DISubprogram(name: "broker_init", scope: !1, file: !1, line: 27, type: !50, scopeLine: 27, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!50 = !DISubroutineType(types: !51)+!51 = !{null, !52}+!52 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !53, size: 64)+!53 = !DIDerivedType(tag: DW_TAG_typedef, name: "broker_t", file: !1, line: 15, baseType: !54)+!54 = distinct !DICompositeType(tag: DW_TAG_structure_type, name: "broker", file: !1, line: 11, size: 1024, elements: !55)+!55 = !{!56, !60, !61}+!56 = !DIDerivedType(tag: DW_TAG_member, name: "msgs", scope: !54, file: !1, line: 12, baseType: !57, size: 960)+!57 = !DICompositeType(tag: DW_TAG_array_type, baseType: !12, size: 960, elements: !58)+!58 = !{!59}+!59 = !DISubrange(count: 5)+!60 = !DIDerivedType(tag: DW_TAG_member, name: "msg_idx", scope: !54, file: !1, line: 13, baseType: !16, size: 32, offset: 960)+!61 = !DIDerivedType(tag: DW_TAG_member, name: "num_msgs", scope: !54, file: !1, line: 14, baseType: !16, size: 32, offset: 992)+!62 = !DILocalVariable(name: "broker", arg: 1, scope: !49, file: !1, line: 27, type: !52)+!63 = !DILocation(line: 27, column: 28, scope: !49)+!64 = !DILocation(line: 28, column: 5, scope: !49)+!65 = !DILocation(line: 28, column: 13, scope: !49)+!66 = !DILocation(line: 28, column: 22, scope: !49)+!67 = !DILocation(line: 29, column: 1, scope: !49)+!68 = distinct !DISubprogram(name: "broker_run", scope: !1, file: !1, line: 31, type: !50, scopeLine: 31, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!69 = !DILocalVariable(name: "broker", arg: 1, scope: !68, file: !1, line: 31, type: !52)+!70 = !DILocation(line: 31, column: 27, scope: !68)+!71 = !DILocalVariable(name: "i", scope: !72, file: !1, line: 32, type: !16)+!72 = distinct !DILexicalBlock(scope: !68, file: !1, line: 32, column: 5)+!73 = !DILocation(line: 32, column: 14, scope: !72)+!74 = !DILocation(line: 32, column: 10, scope: !72)+!75 = !DILocation(line: 32, column: 21, scope: !76)+!76 = distinct !DILexicalBlock(scope: !72, file: !1, line: 32, column: 5)+!77 = !DILocation(line: 32, column: 25, scope: !76)+!78 = !DILocation(line: 32, column: 33, scope: !76)+!79 = !DILocation(line: 32, column: 23, scope: !76)+!80 = !DILocation(line: 32, column: 5, scope: !72)+!81 = !DILocation(line: 33, column: 22, scope: !82)+!82 = distinct !DILexicalBlock(scope: !76, file: !1, line: 32, column: 48)+!83 = !DILocation(line: 33, column: 30, scope: !82)+!84 = !DILocation(line: 33, column: 35, scope: !82)+!85 = !DILocation(line: 33, column: 9, scope: !82)+!86 = !DILocation(line: 34, column: 5, scope: !82)+!87 = !DILocation(line: 32, column: 43, scope: !76)+!88 = !DILocation(line: 32, column: 5, scope: !76)+!89 = distinct !{!89, !80, !90, !46}+!90 = !DILocation(line: 34, column: 5, scope: !72)+!91 = !DILocation(line: 35, column: 1, scope: !68)+!92 = distinct !DISubprogram(name: "main", scope: !1, file: !1, line: 37, type: !93, scopeLine: 37, spFlags: DISPFlagDefinition, unit: !0, retainedNodes: !2)+!93 = !DISubroutineType(types: !94)+!94 = !{!16}+!95 = !DILocalVariable(name: "broker", scope: !92, file: !1, line: 38, type: !53)+!96 = !DILocation(line: 38, column: 14, scope: !92)+!97 = !DILocation(line: 39, column: 5, scope: !92)+!98 = !DILocation(line: 40, column: 5, scope: !92)+!99 = !DILocation(line: 41, column: 1, scope: !92)
fuzzing/Main.hs view
@@ -9,8 +9,6 @@ import qualified Control.Exception as X import Control.Monad (forM, forM_, unless, void, when) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Par.Class (get, spawn)-import Control.Monad.Par.IO (runParIO) import Data.List (isPrefixOf, partition, stripPrefix) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -40,8 +38,9 @@ -- Option Parsing -------------------------------------------------------------- -- | The @clang@ executable and flags for a particular test--- configuration, e.g., @("clang-3.8", "-O -w -g")@-type Clang = (FilePath, String)+-- configuration, e.g., @("clang-3.8", ["/usr/local/include"],+-- "-O -w -g")@+type Clang = (FilePath, [String], String) data Options = Options { optNumTests :: Integer@@ -54,6 +53,9 @@ -- ^ Clangs to use with the fuzzer , optClangFlags :: [String] -- ^ Sets of argument flags to use with each clang configuration+ , optIncludeDirs :: [String]+ -- ^ List of include directories to pass to clang, since those+ -- interact badly with intermediate file names , optJUnitXml :: Maybe FilePath -- ^ Write JUnit test report , optCsmithPath :: Maybe FilePath@@ -80,6 +82,7 @@ , optSaveTests = Nothing , optClangs = ["clang"] , optClangFlags = ["-O -g -w"]+ , optIncludeDirs = [] , optJUnitXml = Nothing , optCsmithPath = Nothing , optCollapse = False@@ -104,6 +107,8 @@ , Option "" ["clang-flags"] (ReqArg addClangFlags "ARGS") $ "specify a set of flags to use with each clang " ++ "e.g., `--clang-flags \"-O\" --clang-flags \"-O -g\"'"+ , Option "I" ["include-dir"] (ReqArg addIncludeDir "DIRECTORY")+ "add a directory to the include search path for clang" , Option "" ["junit-xml"] (ReqArg setJUnitXml "FILEPATH") "output JUnit-style XML test report" , Option "" ["csmith-path"] (ReqArg setCsmithPath "DIRECTORY")@@ -157,6 +162,10 @@ then opt { optClangFlags = [str] } else opt { optClangFlags = str : optClangFlags opt } +addIncludeDir :: String -> Endo Options+addIncludeDir str = Endo $ \opt ->+ opt { optIncludeDirs = str : optIncludeDirs opt }+ setJUnitXml :: String -> Endo Options setJUnitXml str = Endo (\opt -> opt { optJUnitXml = Just str }) @@ -208,34 +217,32 @@ main :: IO () main = withTempDirectory "." ".fuzz." $ \tmpDir -> do opts <- getOptions+ let includeDirs = optIncludeDirs opts when (optSaveTests opts == Nothing && or [optReduceDisasm opts, optReduceAs opts, optReduceExec opts]) $ printUsage [ "--reduce options require --output to be set" ]- -- run the tests within each clang version in parallel. We could- -- parallelize the runs across clang versions as well, but it's- -- probably not worth the complexity at that level of granularity+ liftIO $ putStrLn $ "Temp directory: " ++ tmpDir resultMaps <- forM (optClangs opts) $ \clangExe ->- forM (optClangFlags opts) $ \flags -> runParIO $ do- let clang = (clangExe, flags)+ forM (optClangFlags opts) $ \flags -> do+ let clang = (clangExe, includeDirs, flags) liftIO $ putStrLn $ "[" ++ clangExe ++ " " ++ flags ++ "]"- results' <-+ forM_ includeDirs $ \dir ->+ liftIO $ putStrLn $ "Include directory: " ++ dir+ results <- case optSeeds opts of Nothing ->- forM [1..optNumTests opts] $ \_ ->- spawn $ liftIO $ do+ forM [1..optNumTests opts] $ \_ -> do seed <- randomIO runTest tmpDir clang seed opts Just seeds -> forM seeds $ \seed ->- spawn $ liftIO $ do runTest tmpDir clang seed opts- results <- mapM get results' return (Map.singleton clang results) let allResults' = Map.unions (concat resultMaps) allResults | optCollapse opts = collapseResults allResults' | otherwise = allResults'- forM_ (Map.toList allResults) $ \((clangExe, flags), results) -> do+ forM_ (Map.toList allResults) $ \((clangExe, _, flags), results) -> do let (_passes, fails) = partition isPass results when (not (null fails)) $ do putStrLn $ "[" ++ clangExe ++ " " ++ flags ++ "] " ++@@ -247,7 +254,7 @@ Nothing -> return () Just root -> do createDirectoryIfMissing False root- forM_ (Map.toList allResults) $ \((clangExe, flags), results) ->+ forM_ (Map.toList allResults) $ \((clangExe, _, flags), results) -> when (not (null (filter isFail results))) $ do let clangRoot = root </> (clangExe ++ "_" ++ toUnders " " flags) createDirectoryIfMissing False clangRoot@@ -266,7 +273,7 @@ when (or [ st == DisasmStage && optReduceDisasm opts , st == AsStage && optReduceAs opts , st == ExecStage && optReduceExec opts ]) $- reduce result (clangExe, flags) opts clangRoot+ reduce result (clangExe, includeDirs, flags) opts clangRoot case optJUnitXml opts of Nothing -> return () Just f -> do@@ -274,16 +281,17 @@ writeFile f (ppTopElement xml) reduce :: TestResult -> Clang -> Options -> FilePath -> IO ()-reduce (TestFail st _ TestSrc{..} err) (clangExe, flags) opts clangRoot = do+reduce (TestFail st _ TestSrc{..} err) (clangExe, includeDirs, flags) opts clangRoot = do csmithPath <- getCsmithPath opts -- copy a file for the reduction in place let baseName = dropExtension srcFile srcReduced = clangRoot </> baseName ++ "-reduced.c" scriptFile = clangRoot </> baseName ++ "-reduce.sh"- llvmVersion =+ llvmVersionFlags = case stripPrefix "clang-" clangExe of- Nothing -> ""- Just ver -> "--llvm-version=" ++ ver+ Nothing -> []+ Just ver -> [ "--llvm-version=" ++ ver ]+ includeOpts = concatMap (\dir -> ["-I", dir]) includeDirs copyFile (clangRoot </> srcFile) srcReduced absClangRoot <- makeAbsolute clangRoot let grepPat DisasmStage =@@ -317,22 +325,24 @@ , "set -e" , "" ]- buildBc = unwords [+ buildBc = unwords $ [ clangExe, "-I", csmithPath, flags, "-c" , "-emit-llvm", baseName ++ "-reduced.c", "-o", bcFile- ]- buildLl = unwords [- "llvm-disasm", llvmVersion, bcFile, ">", llFile- ]+ ] ++ includeOpts+ buildLl = unwords $+ [ "llvm-disasm" ] +++ llvmVersionFlags +++ [ bcFile, ">", llFile ] copyBc = unwords [ "cp", bcFile, absClangRoot </> bcFile ] script DisasmStage = unlines $ scriptHeader ++ [ buildBc , copyBc- , unwords [ "llvm-disasm", llvmVersion, bcFile, "2>&1 |"- , "grep", show (fromMaybe "" (grepPat st))- ]+ , unwords $+ [ "llvm-disasm" ] +++ llvmVersionFlags +++ [ bcFile, "2>&1 |" , "grep", show (fromMaybe "" (grepPat st)) ] ] script AsStage = unlines $ scriptHeader ++ [ buildBc@@ -417,15 +427,17 @@ isFail = not . isPass runTest :: FilePath -> Clang -> Seed -> Options -> IO TestResult-runTest tmpDir (clangExe, flags) seed opts = X.handle return $ do+runTest tmpDir (clangExe, includeDirs, flags) seed opts = X.handle return $ do let baseFile = show seed srcFile = baseFile <.> "c" bcFile = baseFile <.> "bc" llFile = baseFile <.> "ll"- llvmVersion =+ llvmVersionFlags = case stripPrefix "clang-" clangExe of- Nothing -> ""- Just ver -> "--llvm-version=" ++ ver+ Nothing -> []+ Just ver -> [ "--llvm-version=" ++ ver ]+ includeOpts = concatMap (\dir -> ["-I", dir]) includeDirs+ putStrLn $ "Testing bitcode file " ++ bcFile ---- Run csmith ---- csmithPath <- getCsmithPath opts callProcess "csmith" [@@ -440,13 +452,14 @@ , "-c", "-emit-llvm" , tmpDir </> srcFile , "-o", tmpDir </> bcFile- ])+ ] ++ includeOpts) clangErr <- waitForProcess h unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed ---- Disassemble ----+ let disasmArgs = llvmVersionFlags ++ [ tmpDir </> bcFile ] (ec, out, err) <-- readProcessWithExitCode "llvm-disasm" [ llvmVersion, tmpDir </> bcFile ] ""+ readProcessWithExitCode "llvm-disasm" disasmArgs "" case ec of ExitFailure c -> do putStrLn "[DISASM ERROR]"@@ -465,7 +478,7 @@ "-I" ++ csmithPath , tmpDir </> llFile , "-o", tmpDir </> "ours"- ]) ""+ ] ++ includeOpts) "" case ec of ExitFailure c -> do putStrLn "[AS ERROR]"@@ -483,7 +496,7 @@ "-I" ++ csmithPath , tmpDir </> bcFile , "-o", tmpDir </> "golden"- ])+ ] ++ includeOpts) clangErr <- waitForProcess h unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed timeout <- getTimeoutCmd@@ -531,7 +544,7 @@ testsuites = map (testsuite hostname nowFmt) (Map.toList allResults) return $ unode "testsuites" testsuites where- fmtClang (clangExe, flags) = toUnders ". " (clangExe ++ "_" ++ flags)+ fmtClang (clangExe, _, flags) = toUnders ". " (clangExe ++ "_" ++ flags) testsuite hostname nowFmt (clang, results) = unode "testsuite" ([ uattr "name" "llvm-disasm fuzzer"
llvm-disasm/LLVMDis.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE ImplicitParams #-} import Data.LLVM.BitCode (parseBitCode, formatError) import Data.LLVM.CFG (buildCFG, CFG(..), blockId)-import Text.LLVM.AST (defBody, modDefines)-import Text.LLVM.PP (ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, ppModule)-import Text.PrettyPrint (Style(..), renderStyle, style)+import Text.LLVM.AST (defBody, modDefines,Module)+import Text.LLVM.PP (ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, llvmPP, llvmVlatest) import Control.Monad (when) import Data.Graph.Inductive.Graph (nmap, emap) import Data.Graph.Inductive.Dot (fglToDotString, showDot)-import Data.Monoid (mconcat, Endo(..))+import Data.Monoid (Endo(..))+import Text.PrettyPrint (Style(..), renderStyle, style)+import Text.Read (readMaybe)+import Text.Show.Pretty (pPrint) import System.Console.GetOpt (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo) import System.Environment (getArgs,getProgName)@@ -19,22 +20,26 @@ data Options = Options { optLLVMVersion :: String , optDoCFG :: Bool+ , optAST :: Bool , optHelp :: Bool } deriving (Show) defaultOptions :: Options defaultOptions = Options {- optLLVMVersion = "3.8"+ optLLVMVersion = show llvmVlatest , optDoCFG = False+ , optAST = False , optHelp = False } options :: [OptDescr (Endo Options)] options = [ Option "" ["llvm-version"] (ReqArg setLLVMVersion "VERSION")- "print assembly compatible with this LLVM version (e.g., 3.8)"+ "output for LLVM version (e.g., 3.5, 3.6. 3.7, 3.8, 4, 5, 6, ...)." , Option "" ["cfg"] (NoArg setDoCFG) "output CFG in graphviz format"+ , Option "" ["ast"] (NoArg setAST)+ "output the Haskell AST instead" , Option "h" ["help"] (NoArg setHelp) "display this message" ]@@ -54,15 +59,26 @@ printUsage :: [String] -> IO () printUsage errs = do prog <- getProgName- let banner = "Usage: " ++ prog ++ " [OPTIONS]"- putStrLn (usageInfo (unlines (errs ++ [banner])) options)+ let banner = [ "Usage: " ++ prog ++ " [OPTIONS]"+ , ""+ , " Converts LLVM bitcode format (.bc) to LLVM text form (.ll) on stdout."+ , " Supports LLVM versions 3.4 through " <> show llvmVlatest <> "."+ , ""+ , " Comparable to the llvm-dis tool from LLVM (which only supports"+ , " the *current* version) but writes to stdout instead of a file."+ ] + putStrLn (usageInfo (unlines (errs ++ banner)) options)+ setLLVMVersion :: String -> Endo Options setLLVMVersion str = Endo (\opt -> opt { optLLVMVersion = str }) setDoCFG :: Endo Options setDoCFG = Endo (\opt -> opt { optDoCFG = True }) +setAST :: Endo Options+setAST = Endo (\opt -> opt { optAST = True })+ setHelp :: Endo Options setHelp = Endo (\opt -> opt { optHelp = True }) @@ -83,20 +99,25 @@ exitFailure Right m -> do- let s = style { lineLength = maxBound, ribbonsPerLine = 1.0 }- case optLLVMVersion opts of- -- try the 3.5 style for 3.4- "3.4" -> putStrLn (renderStyle s (ppLLVM35 (ppModule m)))- "3.5" -> putStrLn (renderStyle s (ppLLVM35 (ppModule m)))- "3.6" -> putStrLn (renderStyle s (ppLLVM36 (ppModule m)))- "3.7" -> putStrLn (renderStyle s (ppLLVM37 (ppModule m)))- "3.8" -> putStrLn (renderStyle s (ppLLVM38 (ppModule m)))- -- try the 3.8 style for 3.9- "3.9" -> putStrLn (renderStyle s (ppLLVM38 (ppModule m)))- -- try the 3.8 style for 4.0- "4.0" -> putStrLn (renderStyle s (ppLLVM38 (ppModule m)))- v -> printUsage ["unsupported LLVM version: " ++ v] >> exitFailure- when (optDoCFG opts) $ do- let cfgs = map (buildCFG . defBody) $ modDefines m- fixup = nmap (show . blockId) . emap (const "")- mapM_ (putStrLn . showDot . fglToDotString . fixup . cfgGraph) cfgs+ if optAST opts+ then pPrint m+ else renderLLVM opts m++renderLLVM :: Options -> Module -> IO ()+renderLLVM opts m = do+ let s = style { lineLength = maxBound, ribbonsPerLine = 1.0 }+ let v = optLLVMVersion opts+ let putRender = putStrLn . renderStyle s+ case readMaybe v :: Maybe Int of+ Just n -> putRender (ppLLVM n (llvmPP m))+ Nothing -> case readMaybe v :: Maybe Float of+ Just 3.4 -> putRender (ppLLVM35 (llvmPP m))+ Just 3.5 -> putRender (ppLLVM35 (llvmPP m))+ Just 3.6 -> putRender (ppLLVM36 (llvmPP m))+ Just 3.7 -> putRender (ppLLVM37 (llvmPP m))+ Just 3.8 -> putRender (ppLLVM38 (llvmPP m))+ _ -> printUsage ["unsupported LLVM version: " ++ v] >> exitFailure+ when (optDoCFG opts) $ do+ let cfgs = map (buildCFG . defBody) $ modDefines m+ fixup = nmap (show . blockId) . emap (const "")+ mapM_ (putStrLn . showDot . fglToDotString . fixup . cfgGraph) cfgs
llvm-pretty-bc-parser.cabal view
@@ -1,13 +1,16 @@+cabal-version: 2.4 Name: llvm-pretty-bc-parser-Version: 0.4.0.0-License: BSD3+Version: 0.4.1.0+License: BSD-3-Clause License-file: LICENSE Author: Trevor Elliott <trevor@galois.com>-Maintainer: Trevor Elliott+Maintainer: Ryan Scott <rscott@galois.com>+ , Kevin Quick <kquick@galois.com>+ , Langston Barrett <langston@galois.com> Category: Text Build-type: Simple-Cabal-version: >=1.10 Synopsis: LLVM bitcode parsing library+Tested-with: GHC==8.8, GHC==8.10, GHC==9.2, GHC==9.4, GHC==9.6 Description: A parser for the LLVM bitcode file format, yielding a Module from the@@ -15,22 +18,31 @@ Extra-source-files: disasm-test/tests/*.ll +extra-doc-files: CHANGELOG.md, README.md+ Flag fuzz Description: Enable fuzzing harness Default: False +Flag regressions+ Description: Enable regression testing build+ Default: False+ Source-repository head type: git- location: http://github.com/galoisinc/llvm-pretty-bc-parser+ location: https://github.com/galoisinc/llvm-pretty-bc-parser Library Hs-source-dirs: src Exposed-modules: Data.LLVM.CFG,- Data.LLVM.BitCode+ Data.LLVM.BitCode,+ -- for testing:+ Data.LLVM.Internal Default-language: Haskell2010 - Other-modules: Data.LLVM.BitCode.BitString,+ Other-modules: Data.LLVM.BitCode.Assert,+ Data.LLVM.BitCode.BitString, Data.LLVM.BitCode.Bitstream, Data.LLVM.BitCode.GetBits, Data.LLVM.BitCode.IR,@@ -48,54 +60,129 @@ Data.LLVM.BitCode.Record Ghc-options: -Wall+ -Wunbanged-strict-patterns+ -Wcompat+ -Wincomplete-uni-patterns+ -Wsimplifiable-class-constraints+ -Wpartial-fields+ -O2+ -funbox-strict-fields+ -fhide-source-paths - Build-depends: base >= 4 && < 5,- containers >= 0.4,- array >= 0.3,- pretty >= 1.0.1,- monadLib >= 3.7.2,- fgl >= 5.5,- cereal >= 0.3.5.2,- bytestring >= 0.9.1,- llvm-pretty>= 0.7.1.1+ Build-depends: array >= 0.3,+ base >= 4.8 && < 5,+ binary >= 0.8,+ bytestring >= 0.10,+ containers >= 0.4,+ fgl >= 5.5,+ llvm-pretty >= 0.12 && < 0.13,+ mtl >= 2.2.2,+ pretty >= 1.0.1,+ uniplate >= 1.6,+ utf8-string >= 1.0 Executable llvm-disasm Main-is: LLVMDis.hs Default-language: Haskell2010 Ghc-options: -Wall+ -Wunbanged-strict-patterns+ -O2+ -funbox-strict-fields Hs-source-dirs: llvm-disasm- Build-depends: bytestring >= 0.9.1,- base >= 4 && < 5,- pretty >= 1.0.1,- containers >= 0.4,- array >= 0.3,- monadLib >= 3.7.2,- fgl >= 5.5,- fgl-visualize >= 0.1,- cereal >= 0.3.5.2,- llvm-pretty>= 0.7.1.0,- llvm-pretty-bc-parser+ Build-depends: array >= 0.3,+ base,+ binary >= 0.8,+ bytestring,+ containers >= 0.4,+ fgl >= 5.5,+ fgl-visualize >= 0.1,+ llvm-pretty-bc-parser,+ llvm-pretty,+ monadLib >= 3.7.2,+ pretty >= 1.0.1,+ pretty-show >= 1.6 +test-suite unit-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Tests.Instances,+ Tests.ExpressionInstances,+ Tests.FuncDataInstances,+ Tests.PrimInstances,+ Tests.StmtInstances,+ Tests.TripleInstances,+ Tests.Metadata+ hs-source-dirs: unit-test+ default-language: Haskell2010+ ghc-options: -W -Wcompat+ -Wunrecognised-warning-flags+ -threaded+ -- other-extensions: OverloadedStrings, ...+ build-depends: base -any,+ containers >= 0.4,+ HUnit -any,+ QuickCheck -any,+ generic-random -any,+ tasty -any,+ tasty-hunit -any,+ tasty-quickcheck -any,+ llvm-pretty -any,+ llvm-pretty-bc-parser+ Test-suite disasm-test type: exitcode-stdio-1.0 Main-is: Main.hs Default-language: Haskell2010 hs-source-dirs: disasm-test Ghc-options: -Wall- build-depends: base >= 4 && < 5,+ build-depends: base,+ containers, process, directory, bytestring,+ exceptions >= 0.10 && < 0.11, filepath,- llvm-pretty>= 0.7.1.0,+ lens,+ optparse-applicative >= 0.18.1.0,+ pretty-show>= 1.6,+ prettyprinter >= 1.7 && < 1.8,+ string-interpolate >= 0.3 && < 0.4,+ syb >= 0.7,+ tasty >= 1.3,+ tasty-expected-failure >= 0.12 && < 0.13,+ tasty-hunit,+ tasty-sugar >= 2.2 && < 2.3,+ transformers >= 0.5 && < 0.7,+ terminal-size >= 0.3 && < 0.4,+ text,+ versions < 7,+ llvm-pretty, llvm-pretty-bc-parser +Executable regression-test+ Main-is: Main.hs+ Default-language: Haskell2010+ hs-source-dirs: regression-test+ Ghc-options: -Wall+ build-depends: base,+ directory,+ filepath,+ foldl,+ text,+ turtle >= 1.6,+ llvm-pretty,+ llvm-pretty-bc-parser+ if flag(regressions)+ Buildable: True+ else+ Buildable: False+ Executable fuzz-llvm-disasm Main-is: Main.hs Default-language: Haskell2010 hs-source-dirs: fuzzing Ghc-options: -Wall -threaded -O2- build-depends: base >= 4 && < 5,+ build-depends: base, process, directory, bytestring,@@ -106,10 +193,8 @@ xml, time, deepseq,- abstract-par,- monad-par, transformers,- llvm-pretty>= 0.7.1.0,+ llvm-pretty, llvm-pretty-bc-parser if flag(fuzz) Buildable: True
+ regression-test/Main.hs view
@@ -0,0 +1,242 @@+-- * Regression tests++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Main where++import Data.LLVM.BitCode (Error(..))++import Control.Monad (when, forM, forM_, filterM)+import Control.Monad.IO.Class (liftIO)+import qualified Control.Foldl as Foldl+import Data.List (nub)+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Semigroup hiding ( Option )+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO+import Data.Typeable (Typeable)+import System.Console.GetOpt (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo)+import qualified System.Directory as Dir+import System.Environment (getArgs, getProgName, getExecutablePath)+import System.Exit (exitFailure, exitSuccess)+import System.FilePath (takeDirectory)+import Data.List (maximumBy)+import Data.Ord (comparing)+import qualified Turtle as T++import Prelude+++----------------------------------------------------------------+-- ** Option parsing++data Options = Options { optTests :: [FilePath] -- ^ Tests+ , optLlvmAs :: Text -- ^ llvm-as name+ , optRev1 :: Text -- ^ Git revision 1+ , optRev2 :: Text -- ^ Git revision 2+ , optAST :: Bool -- ^ Compare generated ASTs?+ , optNew :: Bool -- ^ Use cabal new-build?+ , optHelp :: Bool+ } deriving (Eq, Ord, Show)++defaultOptions :: Options+defaultOptions = Options { optTests = ["disasm-test/tests/factorial2.ll"]+ , optLlvmAs = "llvm-as"+ , optRev1 = "HEAD"+ , optRev2 = "HEAD~1"+ , optAST = False+ , optNew = False+ , optHelp = False+ }++options :: [OptDescr (Endo Options)]+options =+ [ Option "" ["llvm-as"] (ReqArg setLlvmAs "PATH") "path to/name of llvm-as"+ , Option "" ["rev1"] (ReqArg setRev1 "REV") "first git revision to compare"+ , Option "" ["rev2"] (ReqArg setRev2 "REV") "second git revision to compare"+ , Option "" ["ast"] (NoArg setAST) "compare generated ASTs, rather than disassembled bitcode"+ , Option "" ["new"] (NoArg setNew) "use cabal new-build"+ , Option "h" ["help"] (NoArg setHelp) "display this message"+ ]+ where setLlvmAs str = Endo $ \opt -> opt { optLlvmAs = Text.pack str }+ setRev1 str = Endo $ \opt -> opt { optRev1 = Text.pack str }+ setRev2 str = Endo $ \opt -> opt { optRev2 = Text.pack str }+ setAST = Endo $ \opt -> opt { optAST = True }+ setNew = Endo $ \opt -> opt { optNew = True }+ setHelp = Endo $ \opt -> opt { optHelp = True }++addTest :: String -> Endo Options+addTest test = Endo $ \opt -> opt { optTests = test : optTests opt }++getOptions :: IO Options+getOptions =+ do args <- getArgs+ case getOpt (ReturnInOrder addTest) options args of++ (fs, [], []) -> let opts = appEndo (mconcat fs) defaultOptions+ in if optHelp opts+ then printUsage [] >> exitSuccess+ else pure opts++ (_, _, errs) -> printUsage errs >> exitFailure++printUsage :: [String] -> IO ()+printUsage errs = do+ prog <- getProgName+ let banner = "Usage: " ++ prog ++ " [OPTIONS] test1.ll .. testn.ll"+ putStrLn (usageInfo (unlines (errs ++ [banner])) options)++ ----------------------------------------------------------------+-- ** Test running++------------------------------------------------------+-- *** Exceptions++-- | A test failure.+data TestFailure where+ -- | A parser failure. Occurs when the parser from one of the git revisions+ -- couldn't even parse the assembly.+ ParseError :: String -- ^ Which git revision?+ -> Error -- ^ The parse error+ -> TestFailure+ deriving (Typeable, Eq, Ord, Show)++------------------------------------------------------+-- *** Outline++-- **** Preparing++-- 1. Copy the entire source directory (located via the+-- `llvm-pretty-bc-parser.cabal` file) to a temporary "build" directory+-- 2. Create a second temporary "output" directory+-- 3. Copy all test `.ll` files to the "output" directory+-- 4. Assemble the `.ll` files into `.bc` files with `llvm-as`+-- 5. For each of the two specified git revisions,+-- i. Check out that revision+-- ii. Build llvm-disasm+-- iii. Copy the binary to llvm-disasm-<rev> in the output directory++-- **** Testing++-- 6. Run llvm-disasm-<rev> on each `.bc` file, save the output as a file+-- 7. Compare the two outputs, warn the user and print a diff if they aren't the+-- same++------------------------------------------------------+-- *** Running++-- | Beginning in the directory of the current executable, move upwards+-- and try to find `llvm-pretty-bc-parser.cabal`.+findSrc :: IO FilePath+findSrc = do+ parents <- allParents . takeDirectory <$> getExecutablePath+ haveCabalFile <- flip filterM parents $+ fmap ("llvm-pretty-bc-parser.cabal" `elem` ) . Dir.listDirectory+ pure $ flip fromMaybe (listToMaybe haveCabalFile) $+ error $ unlines [ "Couldn't find cabal file in directories:"+ , show parents+ ]+ where -- This is quick-n-dirty: We assume the path has <200 components+ allParents = nub . take 200 . iterate takeDirectory++-- | Run all provided tests.+main :: IO ()+main = T.runManaged $ do+ opts <- liftIO getOptions++ -- (1)+ src <- liftIO findSrc+ buildDir <- T.mktempdir "/tmp" "regression-build"+ T.cptree src buildDir++ -- (2)+ outputDir <- T.mktempdir "/tmp" "regression-out"+ bcfiles <- liftIO $ forM (optTests opts) $ \testFile -> do+ let llName = buildDir T.</> testFile+ let bcName = llName T.<.> "bc"++ -- (3)+ echoText $ "Assembling: " <> Text.pack llName+ T.cp testFile llName++ -- (4)+ (code, stdout, stderr) <-+ T.procStrictWithErr (optLlvmAs opts)+ [ "-o"+ , Text.pack bcName+ , Text.pack llName+ ]+ (pure "")+ exitWithMsg ("Couldn't assemble " <> Text.pack testFile) code stdout stderr+ pure bcName++ let revs = [optRev1 opts, optRev2 opts]++ -- (5)+ T.cd buildDir+ liftIO $ forM_ revs $ \rev -> do+ echoText $ "Compiling: " <> rev++ -- (i)+ (code, stdout, stderr) <- T.procStrictWithErr "git" ["checkout", rev] (pure "")+ exitWithMsg ("Couldn't checkout rev " <> rev) code stdout stderr++ -- (ii)+ let build = (if optNew opts then "new-" else "") <> "build"+ (code, stdout, stderr) <- T.procStrictWithErr "cabal" [build, "llvm-disasm"] (pure "")+ exitWithMsg ("Couldn't `cabal " <> build <> "` revision " <> rev)+ code stdout stderr++ -- (iii)+ -- A bit hacky: some directories contain this text, assume the longest+ -- filepath is the binary+ let dist = "dist" <> if optNew opts then "-newstyle" else ""+ paths <- T.fold (T.find (T.has "llvm-disasm") (Text.unpack dist)) Foldl.list+ T.cp (maximumBy (comparing length) paths)+ (outputDir T.</> Text.unpack ("llvm-disasm-" <> rev))++ -- (6)+ T.cd outputDir+ -- [a, b] <- liftIO $ forM revs $ \rev ->+ resAandB <- liftIO $ forM revs $ \rev ->+ forM bcfiles $ \bcfile -> do+ let exe = Text.pack outputDir <> "/" <> "llvm-disasm-" <> rev+ let ast = ["--ast" | optAST opts]+ let pat = Text.pack bcfile+ (code, stdout, stderr) <-+ T.procStrictWithErr exe (ast ++ [pat]) (pure "")++ exitWithMsg ("Failed when disassembling " <> pat <> " with " <> exe)+ code stdout stderr++ let newPath = bcfile T.<.> Text.unpack rev T.<.> "ll"+ TextIO.writeFile newPath stdout+ pure newPath++ -- (7)+ case resAandB of+ (a:b:[]) ->+ liftIO $ forM_ (zip a b) $ \(ll1, ll2) -> do+ let ll1t = Text.pack ll1+ ll2t = Text.pack ll2++ echoText $ "Diffing: " <> ll1t <> " " <> ll2t+ (code, stdout, stderr) <-+ T.procStrictWithErr "diff" [ll1t, ll2t] (pure "")+ exitWithMsg ("Failed when diffing " <> ll1t <> " with " <> ll2t)+ code stdout stderr++ mapM_ T.echo $ T.textToLines stdout+ _ -> error "Failed to generate old and new disassemblies for comparison"+ -- should never happen, but this avoids requiring MonadFail on matching+ -- [a, b] <- {...step 6...}++ where echoText = liftIO . T.echo . T.unsafeTextToLine+ exitWithMsg msg code stdout stderr =+ when (code /= T.ExitSuccess) $+ mapM_ (mapM_ T.echo . T.textToLines) [msg, stdout, stderr] >>+ exitFailure
+ src/Data/LLVM/BitCode/Assert.hs view
@@ -0,0 +1,115 @@+{- |+Module : Data.LLVM.BitCode.Assert+Description : This module implements exceptions and warnings about bitcode.+License : BSD3+Maintainer : lbarrett+Stability : experimental++This module is meant to be imported qualified as @Assert@++-}++{-# LANGUAGE CPP #-}+module Data.LLVM.BitCode.Assert+ ( failWithMsg+ , unknownEntity+ -- ** Record size+ , recordSizeLess+ , recordSizeGreater+ , recordSizeBetween+ , recordSizeIn++ -- ** Types+ , elimPtrTo+ , elimPtrTo_+ ) where++import Control.Monad (MonadPlus, mplus)+import Control.Monad (when)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Data.LLVM.BitCode.Record (Record)+import qualified Data.LLVM.BitCode.Record as Record+import Text.LLVM.AST (Type', Ident)+import qualified Text.LLVM.AST as AST++supportedCompilerMessage :: [String]+supportedCompilerMessage =+ [ "Are you sure you're using a supported compiler?"+ , "Check here: https://github.com/GaloisInc/llvm-pretty-bc-parser"+ ]++-- | Call 'fail' with a helpful hint to the user+failWithMsg :: MonadFail m => String -> m a+failWithMsg s = fail $ unlines (s:supportedCompilerMessage)++-- | For when an unknown value of an enumeration is encountered+unknownEntity :: (MonadFail m, Show a) => String -> a -> m b+unknownEntity sort val = failWithMsg ("Unknown " ++ sort ++ " " ++ show val)++----------------------------------------------------------------+-- ** Record sizes++recordSizeCmp :: MonadFail m => String -> (Int -> Bool) -> Record -> m ()+recordSizeCmp msg compare_ record =+ let len = length (Record.recordFields record)+ in when (compare_ len) $ failWithMsg $ unlines $+ [ "Invalid record size: " ++ show len, msg ]++recordSizeLess :: MonadFail m => Record -> Int -> m ()+recordSizeLess r i = recordSizeCmp "Expected size less than" (i <=) r++recordSizeGreater :: MonadFail m => Record -> Int -> m ()+recordSizeGreater r i = recordSizeCmp "Expected size greater than" (<= i) r++recordSizeBetween :: MonadFail m => Record -> Int -> Int -> m ()+recordSizeBetween record lb ub =+ recordSizeGreater record lb >> recordSizeLess record ub++recordSizeIn :: MonadFail m => Record -> [Int] -> m ()+recordSizeIn record ns =+ let len = length (Record.recordFields record)+ in when (not (len `elem` ns)) $ failWithMsg $ unlines $+ [ "Invalid record size: " ++ show len+ , "Expected one of: " ++ show ns+ ]+++----------------------------------------------------------------+-- ** Types++-- | Assert that this thing is a @'PtrTo' ty@ and return the underlying @ty@.+--+-- Think carefully before using this function, as it will not work as you would+-- expect when the type is an opaque pointer.+-- See @Note [Pointers and pointee types]@.+elimPtrTo :: (MonadFail m, MonadPlus m) => String -> Type' Ident -> m (Type' Ident)+elimPtrTo msg ptrTy = AST.elimPtrTo ptrTy `mplus`+ (fail $ unlines [ msg+ , "Expected pointer type, found:"+ , show ptrTy+ ])++-- | Assert that this thing is a 'PtrTo' type.+--+-- Think carefully before using this function, as it will not work as you would+-- expect when the type is an opaque pointer.+-- See @Note [Pointers and pointee types]@.+elimPtrTo_ :: (MonadFail m, MonadPlus m) => String -> Type' Ident -> m ()+elimPtrTo_ msg ptrTy = elimPtrTo msg ptrTy >> pure ()++{-+Note [Pointers and pointee types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unlike LLVM itself, llvm-pretty and llvm-pretty-bc-parser allow mixing opaque+and non-opaque pointers. A consequence of this is that we generally avoid+pattern matching on PtrTo (non-opaque pointer) types and inspecting the+underlying pointee types. This sort of code simply won't work for PtrOpaque+types, which lack pointee types.++The elimPtrTo and elimPtrTo_ functions go against this rule, as they retrieve+the pointee type in a PtrTo. These functions are primarily used for supporting+old versions of LLVM which do not store the necessary type information in the+instruction itself.+-}
src/Data/LLVM/BitCode/BitString.hs view
@@ -1,67 +1,173 @@-module Data.LLVM.BitCode.BitString (- BitString(..)+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}++module Data.LLVM.BitCode.BitString+ (+ BitString+ , emptyBitString , toBitString , showBitString , fromBitString- , maskBits- , take, drop, splitAt- ) where+ , bitStringValue+ , take, drop+ , joinBitString+ , NumBits, NumBytes, pattern Bits', pattern Bytes'+ , bitCount, bitCount#+ , bitsToBytes, bytesToBits+ , addBitCounts+ , subtractBitCounts+ )+where +import Data.Bits ( bit, bitSizeMaybe, Bits )+import GHC.Exts+import Numeric ( showIntAtBase, showHex )+ import Prelude hiding (take,drop,splitAt) -import Data.Bits ((.&.),(.|.),shiftL,shiftR,bit)-import Data.Monoid (Monoid(..))-import Numeric (showIntAtBase)+----------------------------------------------------------------------+-- Define some convenience newtypes to clarify whether the count of bits or count+-- of bytes is being referenced, and to convert between the two. +newtype NumBits = NumBits Int deriving (Show, Eq, Ord)+newtype NumBytes = NumBytes Int deriving (Show, Eq, Ord) +pattern Bits' :: Int -> NumBits+pattern Bits' n = NumBits n+{-# COMPLETE Bits' #-}++pattern Bytes' :: Int -> NumBytes+pattern Bytes' n = NumBytes n+{-# COMPLETE Bytes' #-}++bitCount :: NumBits -> Int+bitCount (NumBits n) = n++bitCount# :: NumBits -> Int#+bitCount# (NumBits (I# n#)) = n#++{-# INLINE addBitCounts #-}+addBitCounts :: NumBits -> NumBits -> NumBits+addBitCounts (NumBits (I# a#)) (NumBits (I# b#)) = NumBits (I# (a# +# b#))++{-# INLINE subtractBitCounts #-}+subtractBitCounts :: NumBits -> NumBits -> NumBits+subtractBitCounts (NumBits (I# a#)) (NumBits (I# b#)) = NumBits (I# (a# -# b#))++{-# INLINE bytesToBits #-}+bitsToBytes :: NumBits -> (NumBytes, NumBits)+bitsToBytes (NumBits (I# n#)) = ( NumBytes (I# (n# `uncheckedIShiftRL#` 3#))+ , NumBits (I# (n# `andI#` 7#))+ )++{-# INLINE bitsToBytes #-}+bytesToBits :: NumBytes -> NumBits+bytesToBits (NumBytes (I# n#)) = NumBits (I# (n# `uncheckedIShiftL#` 3#))++----------------------------------------------------------------------+ data BitString = BitString- { bsLength :: !Int- , bsData :: !Integer- } deriving Show+ { bsLength :: !NumBits+ , bsData :: !Int+ -- Note: the bsData was originally an Integer, which allows an essentially+ -- unlimited size value. However, this adds some overhead to various+ -- computations, and since LLVM Bitcode is unlikely to ever represent values+ -- greater than the native size (64 bits) as discrete values. By changing+ -- this to @Int@, the use of unboxed calculations is enabled for better+ -- performance.+ --+ -- The use of Int is potentially unsound because GHC only guarantees it's a+ -- signed integer of at least 32-bits. However current implementations in+ -- all environments where it's reasonable to use this parser have a 64-bit+ -- Int implementation. This can be verified via:+ --+ -- > import Data.Bits+ -- > bitSizeMaybe (maxBound :: Int) >= Just 64+ --+ -- There's no good location here to automate this check (perhaps+ -- GetBits.hs:runGetBits?), which is why it isn't verified at runtime.+ } deriving (Show, Eq) -instance Eq BitString where- BitString n i == BitString m j = n == m && i == j+-- | Create an empty BitString -instance Monoid BitString where- mempty = BitString 0 0- mappend (BitString n i) (BitString m j) =- BitString (n+m) (i .|. (j `shiftL` n))+emptyBitString :: BitString+emptyBitString = BitString (NumBits 0) 0 ++-- | Join two BitString representations together to form a single larger+-- BitString. The first BitString is the \"lower\" value portion of the resulting+-- BitString.++joinBitString :: BitString -> BitString -> BitString+joinBitString (BitString (Bits' (I# szA#)) (I# a#))+ (BitString (Bits' (I# szB#)) (I# b#)) =+ BitString { bsLength = NumBits (I# (szA# +# szB#))+ , bsData = I# (a# `orI#` (b# `uncheckedIShiftL#` szA#))+ }++ -- | Given a number of bits to take, and an @Integer@, create a @BitString@.-toBitString :: Int -> Integer -> BitString-toBitString len val = BitString len (val .&. maskBits len) -fromBitString :: Num a => BitString -> a-fromBitString (BitString l i) = fromIntegral (i .&. maskBits l)+toBitString :: NumBits -> Int -> BitString+toBitString len@(Bits' (I# len#)) (I# val#) =+ let !mask# = (1# `uncheckedIShiftL#` len#) -# 1#+ in BitString len (I# (val# `andI#` mask#)) ++-- | Extract the referenced Integer value from a BitString++bitStringValue :: BitString -> Int+bitStringValue = bsData+++-- | Extract a target (Num) value of the desired type from a BitString (using+-- fromInteger to perform the target type conversion).++fromBitString :: (Num a, Bits a) => BitString -> a+fromBitString (BitString l i) =+ case bitSizeMaybe x of+ Nothing -> x+ Just n+ -- Verify that the bitstring size is less than the target size, or if it is+ -- greater, that the extra upper bits are all zero.+ | n >= bitCount l || (ival < bit n) -> x+ | otherwise -> error (unwords+ [ "Data.LLVM.BitCode.BitString.fromBitString: bitstring value of length", show l+ , "(mask=0x" <> showHex i ")"+ , "could not be parsed into type with only", show n, "bits"+ ])+ where+ x = fromInteger ival -- use Num to convert the Integer to the target type+ ival = toInteger i -- convert input to an Integer for ^^++ showBitString :: BitString -> ShowS showBitString bs = showString padding . showString bin where bin = showIntAtBase 2 fmt (bsData bs) ""- padding = replicate (bsLength bs - length bin) '0'+ padding = replicate (bitCount (bsLength bs) - length bin) '0' fmt 0 = '0' fmt 1 = '1' fmt _ = error "invalid binary digit value" --- | Generate a mask from a number of bits desired.-maskBits :: Int -> Integer-maskBits len- | len <= 0 = 0- | otherwise = pred (bit len)--take :: Int -> BitString -> BitString+-- | Extract a smaller BitString with the specified number of bits from the+-- \"start\" of a larger BitString.+take :: NumBits -> BitString -> BitString take n bs@(BitString l i) | n >= l = bs | otherwise = toBitString n i -drop :: Int -> BitString -> BitString-drop n (BitString l i)- | n >= l = mempty- | otherwise = BitString (l - n) (i `shiftR` n) -splitAt :: Int -> BitString -> (BitString,BitString)-splitAt n bs@(BitString l i)- | n <= 0 = (mempty, bs)- | n >= l = (bs, mempty)- | otherwise = (toBitString n i, toBitString (l - n) (i `shiftR` n))+-- | Remove the specified number of bits from the beginning of a BitString and+-- return the remaining as a smaller BitString.++drop :: NumBits -> BitString -> BitString+drop !n !(BitString l i)+ | n >= l = emptyBitString+ | otherwise =+ let !(I# n#) = bitCount n+ !(I# l#) = bitCount l+ !(I# i#) = i+ in BitString (NumBits (I# (l# -# n#))) (I# (i# `uncheckedIShiftRL#` n#))
src/Data/LLVM/BitCode/Bitstream.hs view
@@ -16,60 +16,56 @@ , parseMetadataStringLengths ) where -import Data.LLVM.BitCode.BitString as BS-import Data.LLVM.BitCode.GetBits+import Data.LLVM.BitCode.BitString as BS+import Data.LLVM.BitCode.GetBits -import Control.Applicative ((<$>))-import Control.Monad (unless,replicateM,guard)-import Data.Monoid (Monoid(..))-import Data.Word (Word8,Word16,Word32)+import Control.Monad ( unless, replicateM, guard )+import Data.Bits ( Bits ) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map-import qualified Data.Serialize as C+import Data.Word ( Word8, Word16, Word32 ) -- Primitive Reads ------------------------------------------------------------- -- | Parse a @Bool@ out of a single bit. boolean :: GetBits Bool-boolean = do- bs <- fixed 1- return (bsData bs == 1)+boolean = ((1 :: Word8) ==) . fromBitString <$> fixed (Bits' 1) + -- | Parse a Num type out of n-bits.-numeric :: Num a => Int -> GetBits a-numeric n = do- bs <- fixed n- return (fromIntegral (bsData bs))+numeric :: (Num a, Bits a) => NumBits -> GetBits a+numeric n = fromBitString <$> fixed n + -- | Get a @BitString@ formatted as vbr.-vbr :: Int -> GetBits BitString-vbr n = loop mempty+vbr :: NumBits -> GetBits BitString+vbr n = loop emptyBitString where- len = n - 1+ len = subtractBitCounts n (Bits' 1) loop acc = acc `seq` do chunk <- fixed len cont <- boolean- let acc' = acc `mappend` chunk+ let acc' = acc `joinBitString` chunk if cont then loop acc' else return acc' -- | Process a variable-bit encoded integer.-vbrNum :: Num a => Int -> GetBits a+vbrNum :: (Num a, Bits a) => NumBits -> GetBits a vbrNum n = fromBitString <$> vbr n -- | Decode a 6-bit encoded character.-char6 :: GetBits Char+char6 :: GetBits Word8 char6 = do- word <- numeric 6+ word <- numeric $ Bits' 6 case word of- n | 0 <= n && n <= 25 -> return (toEnum (n + 97))- | 26 <= n && n <= 51 -> return (toEnum (n + 39))- | 52 <= n && n <= 61 -> return (toEnum (n - 4))- 62 -> return '.'- 63 -> return '_'+ n | 0 <= n && n <= 25 -> return (n + 97)+ | 26 <= n && n <= 51 -> return (n + 39)+ | 52 <= n && n <= 61 -> return (n - 4)+ 62 -> return (fromIntegral (fromEnum '.'))+ 63 -> return (fromIntegral (fromEnum '_')) _ -> fail "invalid char6" @@ -81,17 +77,19 @@ } deriving (Show) parseBitstream :: S.ByteString -> Either String Bitstream-parseBitstream = C.runGet (runGetBits getBitstream)+parseBitstream = runGetBits getBitstream parseBitCodeBitstream :: S.ByteString -> Either String Bitstream-parseBitCodeBitstream = C.runGet (runGetBits getBitCodeBitstream)+parseBitCodeBitstream = parseBitCodeBitstreamLazy . L.fromStrict parseBitCodeBitstreamLazy :: L.ByteString -> Either String Bitstream-parseBitCodeBitstreamLazy = C.runGetLazy (runGetBits getBitCodeBitstream)+parseBitCodeBitstreamLazy = runGetBits getBitCodeBitstream . L.toStrict -- | The magic constant at the beginning of all llvm-bitcode files. bcMagicConst :: BitString-bcMagicConst = BitString 8 0x42 `mappend` BitString 8 0x43+bcMagicConst = toBitString (Bits' 8) 0x42+ `joinBitString`+ toBitString (Bits' 8) 0x43 -- | Parse a @Bitstream@ from either a normal bitcode file, or a wrapped -- bitcode.@@ -101,31 +99,32 @@ case mb of Nothing -> getBitstream Just () -> do- skip 32 -- Version- off <- fixed 32+ skip $ Bits' 32 -- Version+ off <- fixed $ Bits' 32 -- the offset should always be 20 (5 word32 values) unless (fromBitString off == (20 :: Int)) (fail ("invalid offset value: " ++ show off))- size <- fixed 32- skip 32 -- CPUType- isolate (fromBitString size `div` 4) getBitstream+ size <- Bytes' . fromBitString <$> (fixed $ Bits' 32)+ skip $ Bits' 32 -- CPUType+ isolate size getBitstream bcWrapperMagicConst :: BitString-bcWrapperMagicConst = mconcat [byte 0xDE, byte 0xC0, byte 0x17, byte 0x0B]+bcWrapperMagicConst =+ foldr1 joinBitString [ byte 0xDE, byte 0xC0, byte 0x17, byte 0x0B] where- byte = BitString 8+ byte = toBitString (Bits' 8) guardWrapperMagic :: GetBits () guardWrapperMagic = do- magic <- fixed 32+ magic <- fixed (Bits' 32) guard (magic == bcWrapperMagicConst) -- | Parse a @Bitstream@. getBitstream :: GetBits Bitstream getBitstream = label "bitstream" $ do- bc <- fixed 16+ bc <- fixed $ Bits' 16 unless (bc == bcMagicConst) (fail "Invalid magic number")- appMagic <- numeric 16+ appMagic <- numeric $ Bits' 16 entries <- getTopLevelEntries return Bitstream { bsAppMagic = appMagic@@ -141,7 +140,7 @@ -- | Parse top-level entries. getTopLevelEntries :: GetBits [Entry]-getTopLevelEntries = fst <$> getEntries 2 Map.empty emptyAbbrevMap True+getTopLevelEntries = fst <$> getEntries (Bits' 2) Map.empty emptyAbbrevMap True -- | Get as many entries as we can parse. getEntries :: AbbrevIdWidth -> BlockInfoMap -> AbbrevMap -> Bool@@ -183,7 +182,7 @@ -- Abbreviation IDs ------------------------------------------------------------ -type AbbrevIdWidth = Int+type AbbrevIdWidth = NumBits data AbbrevId = END_BLOCK@@ -214,12 +213,12 @@ -- | Parse an abbreviation definition. getDefineAbbrev :: GetBits DefineAbbrev getDefineAbbrev =- label "define abbrev" (DefineAbbrev `fmap` (getAbbrevOps =<< vbrNum 5))+ label "define abbrev" (DefineAbbrev `fmap` (getAbbrevOps =<< vbrNum (Bits' 5))) data AbbrevOp = OpLiteral !BitString- | OpFixed !Int- | OpVBR !Int+ | OpFixed !NumBits+ | OpVBR !NumBits | OpArray AbbrevOp | OpChar6 | OpBlob@@ -239,12 +238,12 @@ let one = fmap (\x -> (x,1)) isLiteral <- boolean if isLiteral- then one (OpLiteral <$> vbr 8)+ then one (OpLiteral <$> (vbr $ Bits' 8)) else do- enc <- numeric 3+ enc <- numeric $ Bits' 3 case enc :: Word8 of- 1 -> one (OpFixed <$> vbrNum 5)- 2 -> one (OpVBR <$> vbrNum 5)+ 1 -> one (OpFixed . Bits' <$> vbrNum (Bits' 5))+ 2 -> one (OpVBR . Bits' <$> vbrNum (Bits' 5)) 3 -> do (op,n) <- getAbbrevOp return (OpArray op, n+1)@@ -285,7 +284,7 @@ data Block = Block { blockId :: !BlockId , blockNewAbbrevLen :: !AbbrevIdWidth- , blockLength :: !Int+ , blockLength :: !NumBytes , blockEntries :: [Entry] } deriving (Show) @@ -304,10 +303,12 @@ -- | A generic block. getGenericBlock :: BlockInfoMap -> GetBits (Block,BlockInfoMap) getGenericBlock bim = label "block " $ do- blockid <- vbrNum 8- newabbrevlen <- vbrNum 4+ blockid <- vbrNum $ Bits' 8+ newabbrevlen <- Bits' <$> (vbrNum $ Bits' 4) align32bits- blocklen <- numeric 32+ -- Block length in the bitcode is the number of 32-bit longwords; internally it+ -- is stored as the number of bytes.+ blocklen <- Bytes' . (*4) <$> (numeric $ Bits' 32) let am = lookupAbbrevMap blockid bim (entries,bim') <- isolate blocklen (getEntries newabbrevlen bim am False) let block = Block@@ -374,9 +375,9 @@ -- | Parse an unabbreviated record. getUnabbrevRecord :: GetBits UnabbrevRecord getUnabbrevRecord = label "unabbreviated record" $ do- code <- vbrNum 6- numops <- vbrNum 6- ops <- replicateM numops (vbr 6)+ code <- vbrNum $ Bits' 6+ numops <- vbrNum $ Bits' 6+ ops <- replicateM numops (vbr $ Bits' 6) return UnabbrevRecord { unabbrevCode = code , unabbrevOps = ops@@ -412,7 +413,7 @@ | FieldFixed !BitString | FieldVBR !BitString | FieldArray [Field]- | FieldChar6 !Char+ | FieldChar6 !Word8 | FieldBlob !S.ByteString deriving Show @@ -430,13 +431,13 @@ OpVBR width -> FieldVBR <$> vbr width OpArray ty -> do- len <- vbrNum 6+ len <- vbrNum $ Bits' 6 FieldArray <$> replicateM len (interpAbbrevOp ty) OpChar6 -> FieldChar6 <$> char6 OpBlob -> do- len <- vbrNum 6+ len <- Bytes' <$> (vbrNum $ Bits' 6) bytes <- bytestring len return (FieldBlob bytes) @@ -444,4 +445,4 @@ -- Metadata String Lengths ----------------------------------------------------- parseMetadataStringLengths :: Int -> S.ByteString -> Either String [Int]-parseMetadataStringLengths n = C.runGet (runGetBits (replicateM n (vbrNum 6)))+parseMetadataStringLengths n = runGetBits (replicateM n (vbrNum $ Bits' 6))
src/Data/LLVM/BitCode/GetBits.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+ module Data.LLVM.BitCode.GetBits ( GetBits , runGetBits@@ -9,59 +14,96 @@ , skip ) where -import Data.LLVM.BitCode.BitString+import Data.LLVM.BitCode.BitString -import Control.Applicative (Applicative(..),Alternative(..),(<$>))-import Control.Arrow (first)-import Control.Monad (MonadPlus(..),when,replicateM_)-import Data.Bits (shiftR)-import Data.ByteString (ByteString)-import Data.Monoid (mempty,mappend)-import Data.Word (Word32)-import qualified Data.Serialize as C+import Control.Applicative ( Alternative(..) )+import Control.Monad ( MonadPlus(..) )+import Data.Bits ( shiftR, shiftL, (.&.), (.|.) )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import GHC.Exts+import GHC.Word +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+import qualified Control.Monad.Fail+#endif -- Bit-level Parsing ----------------------------------------------------------- -newtype GetBits a = GetBits { unGetBits :: SubWord -> C.Get (a,SubWord) }+newtype GetBits a =+ GetBits { unGetBits :: BitPosition -> BS.ByteString+ -> (# BitsGetter a, BitPosition #)+ } +type BitPosition = (# Int#, Int# #) -- (# current bit pos, maximum bit pos #)++type BitsGetter a = Either String a -- Left is fail++ -- | Run a @GetBits@ action, returning its value, and the number of bits offset -- into the next byte of the stream.-runGetBits :: GetBits a -> C.Get a-runGetBits m = fst `fmap` unGetBits m Aligned+runGetBits :: GetBits a -> ByteString -> Either String a+runGetBits m bs =+ let !startPos# = (# 0#, bitCount# $ bytesToBits $ Bytes' $ BS.length bs #)+ !(# g, _ #) = unGetBits m startPos# bs+ in g + instance Functor GetBits where {-# INLINE fmap #-}- fmap f m = GetBits (\ off -> first f <$> unGetBits m off)+ fmap f m = GetBits $+ \ !pos# inp -> let !(# b, n# #) = unGetBits m pos# inp+ in (# f <$> b, n# #) instance Applicative GetBits where {-# INLINE pure #-}- pure x = GetBits (\ off -> return (x,off))+ pure x = GetBits $ \ !pos# _ -> (# pure x, pos# #) {-# INLINE (<*>) #-}- f <*> x = GetBits $ \ off0 -> do- (g,off1) <- unGetBits f off0- (y,off2) <- unGetBits x off1- return (g y,off2)+ f <*> x =+ GetBits $ \ !pos# inp ->+ let !(# g, n# #) = unGetBits f pos# inp+ in case g of+ Right g' ->+ let !(# y, m# #) = unGetBits x n# inp+ in case y of+ Right y' -> (# Right $ g' y', m# #)+ Left e -> (# Left e, m# #)+ Left e -> (# Left e, n# #) instance Monad GetBits where {-# INLINE return #-} return = pure {-# INLINE (>>=) #-}- m >>= f = GetBits $ \ off0 -> do- (x,off1) <- unGetBits m off0- unGetBits (f x) off1+ m >>= f = GetBits $ \ !pos# inp ->+ let !(# g, n# #) = unGetBits m pos# inp+ !(# gr, nr# #) = case g of+ Left e -> (# Left e, n# #)+ Right a -> unGetBits (f a) n# inp+ in (# gr, nr# #) +#if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-}- fail str = GetBits (\ _ -> fail str)+ fail e = GetBits $ \ p _ -> (# Left e, p #)+#endif +instance MonadFail GetBits where+ {-# INLINE fail #-}+ fail e = GetBits $ \ p _ -> (# Left e, p #)+ instance Alternative GetBits where {-# INLINE empty #-}- empty = GetBits (\_ -> mzero)+ empty = GetBits $ \ p _ -> (# Left "GetBits is empty!", p #) {-# INLINE (<|>) #-}- a <|> b = GetBits (\ off -> unGetBits a off <|> unGetBits b off)+ a <|> b = GetBits+ $ \ !pos# inp ->+ let !r@(# g, _ #) = unGetBits a pos# inp+ in case g of+ Right _ -> r+ Left _ -> unGetBits b pos# inp instance MonadPlus GetBits where {-# INLINE mzero #-}@@ -71,88 +113,274 @@ mplus = (<|>) --- Sub-word Bit Parsing State --------------------------------------------------+-- | Extracts an Integer value of the specified number of bits from a ByteString,+-- starting at the indicated bit position (fails with Left if the range to+-- extract is not valid... i.e. > bitLimit). Returns the Integer value along+-- with the bit position following the extraction. --- This assumes that we'll pad any incoming bitcode to a 32-bit boundary, but--- given the use of 32-bit padding already, it seems likely that all bitcode--- files get padded to a 32-bit boundary.-data SubWord- = SubWord !Int !Word32- | Aligned- deriving (Show)+-- There are two implementations: one builds an integer value by shifting bits,+-- then shifts and masks the result to get the final value. The other uses+-- unlifted values and avoids the final shift by being smarter about individual+-- compositions. Their functionality should be identical, but it may be easier+-- to debug the first. -splitWord :: Int -> Int -> Word32 -> (BitString,Either Int SubWord)-splitWord n l w = case compare n l of- LT -> (toBitString n (fromIntegral w), Right (SubWord (l - n) (w `shiftR` n)))- EQ -> (toBitString n (fromIntegral w), Right Aligned)- GT -> (toBitString l (fromIntegral w), Left (n - l))+_extractFromByteString' :: NumBits {-^ the last bit accessible in the ByteString -}+ -> NumBits {-^ the bit to start extraction at -}+ -> NumBits {-^ the number of bits to extract -}+ -> ByteString {-^ the ByteString to extract from -}+ -> Either String (Int, NumBits)+_extractFromByteString' bitLimit startBit numBits bs =+ let Bytes' s8 = fst (bitsToBytes startBit)+ Bytes' r8 = fst (bitsToBytes numBits)+ rcnt = r8 + 2 -- 2 == pre-shift overflow byte on either side --- | Get a @BitString@, yielding a new partial word.-getBitString :: Int -> C.Get (BitString,SubWord)-getBitString 0 = return (mempty,Aligned)-getBitString n = getBitStringPartial n 32 =<< C.getWord32le+ -- Extract the relevant bits from the ByteCode, with padding to byte+ -- boundaries into ws.+ ws = BS.take rcnt $ BS.drop s8 bs --- | A combination of @splitWord@ and @getBitString@ that takes an initial--- partial word as input.-getBitStringPartial :: Int -> Int -> Word32 -> C.Get (BitString,SubWord)-getBitStringPartial n l w = case splitWord n l w of- (bs,Right off) -> return (bs, off)- (bs,Left n') -> do- (rest,off) <- getBitString n'- return (bs `mappend` rest, off)+ -- Combine the extracted bytes into an Integer value in wi.+ wi = BS.foldr (\w a -> a `shiftL` 8 .|. fromIntegral w) (0::Int) ws --- | Skip a byte of input, which must be zero.-skipZeroByte :: C.Get ()-skipZeroByte = do- x <- C.getWord8- when (x /= 0) $ fail "alignment padding was not zeros"+ -- Mask is 0-bit based set of bits wanted in the result+ mask = ((1::Int) `shiftL` bitCount numBits) - 1 --- | Get a @ByteString@ of @n@ bytes, and then align to 32 bits.-getByteString :: Int -> C.Get (ByteString,SubWord)-getByteString n = do- bs <- C.getByteString n- replicateM_ ((- n) `mod` 4) skipZeroByte- return (bs, Aligned)+ -- Shift the desired value down to byte alignment and then discard any+ -- excess high bits.+ vi = wi `shiftR` (bitCount startBit .&. 7) .&. mask + updPos = addBitCounts startBit numBits+ in if updPos > bitLimit+ then Left ("Attempt to read bits past limit (newPos="+ <> show updPos <> ", limit=" <> show bitLimit <> ")"+ )+ else Right (vi, updPos) +extractFromByteString :: Int# {-^ the last bit accessible in the ByteString -}+ -> Int# {-^ the bit to start extraction at -}+ -> Int# {-^ the number of bits to extract -}+ -> ByteString {-^ the ByteString to extract from -}+ -> Either String (() -> (# Int#, Int# #))+extractFromByteString !bitLim# !sBit# !nbits# bs =+ if isTrue# ((1# `uncheckedIShiftL#` (nbits#)) /=# 0#)+ -- (nbits# -# 1#) above would allow 64-bit value extraction, but this+ -- function cannot actually support a size of 64, because Int# is signed,+ -- so it doesn't properly use the high bit in numeric operations. This+ -- seems to be OK at this point because LLVM bitcode does not attempt to+ -- encode actual 64-bit values.+ then+ let !updPos# = sBit# +# nbits#+ in if isTrue# (updPos# <=# bitLim#)+ then+ let !s8# = sBit# `uncheckedIShiftRL#` 3#+ !hop# = sBit# `andI#` 7#+ !r8# = ((hop# +# nbits# +# 7#) `uncheckedIShiftRL#` 3#)+ !mask# = (1# `uncheckedIShiftL#` nbits#) -# 1#+ -- Here, s8# is the size in 8-bit bytes, hop# is the number of+ -- bits shifted from the byte boundary, r8# is the rounded number+ -- of bytes actually needed to retrieve to get the value to+ -- account for shifting, and mask# is the mask for the final+ -- target set of bits after shifting.+#if MIN_VERSION_base(4,16,0)+ word8ToInt !w8# = word2Int# (word8ToWord# w8#)+#else+ -- technically #if !MIN_VERSION_ghc_prim(0,8,0), for GHC 9.2, but+ -- since ghc_prim isn't a direct dependency and is re-exported+ -- from base, this define needs to reference the base version.+ word8ToInt = word2Int#+#endif+ -- getB# gets a value from a byte starting at bit0 of the byte+ getB# :: Int# -> Int#+ getB# !i# =+ case i# of+ 0# -> let !(W8# w#) = bs `BS.index` (I# s8#)+ in word8ToInt w#+ _ -> let !(W8# w#) = (bs `BS.index` (I# (s8# +# i#)))+ in (word8ToInt w#) `uncheckedIShiftL#` (8# *# i#)+ -- getSB# gets a value from a byte shifting from a non-zero start+ -- bit within the byte.+ getSB# :: Int# -> Int#+ getSB# !i# =+ case i# of+ 0# -> let !(W8# w#) = bs `BS.index` (I# s8#)+ in (word8ToInt w#) `uncheckedIShiftRL#` hop#+ _ -> let !(W8# w#) = bs `BS.index` (I# (s8# +# i#))+ !shft# = (8# *# i#) -# hop#+ in (word8ToInt w#) `uncheckedIShiftL#` shft#+ !vi# = mask# `andI#`+ (case hop# of+ 0# -> case r8# of+ 1# -> getB# 0#+ 2# -> getB# 0# `orI#` getB# 1#+ 3# -> getB# 0# `orI#` getB# 1# `orI#`+ getB# 2#+ 4# -> getB# 0# `orI#` getB# 1# `orI#`+ getB# 2# `orI#` getB# 3#+ 5# -> getB# 0# `orI#` getB# 1# `orI#`+ getB# 2# `orI#` getB# 3# `orI#`+ getB# 4#+ 6# -> getB# 0# `orI#` getB# 1# `orI#`+ getB# 2# `orI#` getB# 3# `orI#`+ getB# 4# `orI#` getB# 5#+ 7# -> getB# 0# `orI#` getB# 1# `orI#`+ getB# 2# `orI#` getB# 3# `orI#`+ getB# 4# `orI#` getB# 5# `orI#`+ getB# 6#+ 8# -> getB# 0# `orI#` getB# 1# `orI#`+ getB# 2# `orI#` getB# 3# `orI#`+ getB# 4# `orI#` getB# 5# `orI#`+ getB# 6# `orI#` getB# 7#+ -- This is the catch-all loop for other sizes+ -- not addressed above.+ _ -> let join !(W8# w#) !(I# a#) =+ I# ((a# `uncheckedIShiftL#` 8#)+ `orI#` (word8ToInt w#))+ bs' = BS.take (I# (r8# +# 2#))+ $ BS.drop (I# s8#) bs+ !(I# v#) = BS.foldr join (0::Int) bs'+ in mask# `andI#` (v# `uncheckedIShiftRL#` hop#)+ _ -> case r8# of+ 1# -> getSB# 0#+ 2# -> getSB# 0# `orI#` getSB# 1#+ 3# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2#+ 4# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3#+ 5# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3# `orI#`+ getSB# 4#+ 6# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3# `orI#`+ getSB# 4# `orI#` getSB# 5#+ 7# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3# `orI#`+ getSB# 4# `orI#` getSB# 5# `orI#`+ getSB# 6#+ 8# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3# `orI#`+ getSB# 4# `orI#` getSB# 5# `orI#`+ getSB# 6# `orI#` getSB# 7#+ -- n.b. these are hand-unrolled cases for common+ -- sizes this is called for.+ 9# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3# `orI#`+ getSB# 4# `orI#` getSB# 5# `orI#`+ getSB# 6# `orI#` getSB# 7# `orI#`+ getSB# 8#+ 18# -> getSB# 0# `orI#` getSB# 1# `orI#`+ getSB# 2# `orI#` getSB# 3# `orI#`+ getSB# 4# `orI#` getSB# 5# `orI#`+ getSB# 6# `orI#` getSB# 7# `orI#`+ getSB# 8# `orI#` getSB# 9# `orI#`+ getSB# 10# `orI#` getSB# 11# `orI#`+ getSB# 12# `orI#` getSB# 13# `orI#`+ getSB# 14# `orI#` getSB# 15# `orI#`+ getSB# 16# `orI#` getSB# 17#+ -- This is the catch-all loop for other sizes+ -- not addressed above.+ _ -> let join !(W8# w#) !(I# a#) =+ I# ((a# `uncheckedIShiftL#` 8#)+ `orI#` (word8ToInt w#))+ bs' = BS.take (I# (r8# +# 2#))+ $ BS.drop (I# s8#) bs+ !(I# v#) = BS.foldr join (0::Int) bs'+ in mask# `andI#` (v# `uncheckedIShiftRL#` hop#)+ )+ in Right $ \_ -> (# vi#, updPos# #)+ else Left "Attempt to read bits past limit"+ else+ -- BitString stores an Int, but number of extracted bits is larger than+ -- an Int can represent.+ Left "Attempt to extracted large value"++ -- Basic Interface ------------------------------------------------------------- -- | Read zeros up to an alignment of 32-bits. align32bits :: GetBits ()-align32bits = GetBits $ \ off -> case off of- Aligned -> return ((),Aligned)- SubWord _ 0 -> return ((),Aligned)- SubWord _ _ -> fail "alignment padding was not zeros"+align32bits = GetBits $ \ !pos# inp ->+ let !(# curBit#, ttlBits# #) = pos#+ !s32# = curBit# `andI#` 31#+ !r32# = 32# -# s32# -- num bits to reach next 32-bit boundary+ nonZero = "alignments @" <> show (I# curBit#)+ <> " not zeroes up to 32-bit boundary"+ in if isTrue# (s32# ==# 0#)+ then (# Right (), pos# #)+ else case extractFromByteString ttlBits# curBit# r32# inp of+ Right getRes ->+ let !(# vi#, newPos# #) = getRes ()+ in if isTrue# (vi# ==# 0#)+ then (# Right (), (# newPos#, ttlBits# #) #)+ else (# Left nonZero, pos# #)+ Left e -> (# Left e, pos# #) + -- | Read out n bits as a @BitString@.-fixed :: Int -> GetBits BitString-fixed n = GetBits $ \ off -> case off of- Aligned -> getBitString n- SubWord l w -> getBitStringPartial n l w+fixed :: NumBits -> GetBits BitString+fixed !(Bits' (I# n#)) = GetBits+ $ \ !s@(# cur#, lim# #) ->+ \inp ->+ case extractFromByteString lim# cur# n# inp of+ Right getRes ->+ let !(# v#, p# #) = getRes ()+ in (# pure $ toBitString (Bits' (I# n#)) (I# v#)+ , (# p#, lim# #)+ #)+ Left e -> (# Left e, s #) --- | Read out n bytes as a @ByteString@, aligning to a 32-bit boundary before and after.-bytestring :: Int -> GetBits ByteString-bytestring n = GetBits $ \ off -> case off of- Aligned -> getByteString n- SubWord _ 0 -> getByteString n- SubWord _ _ -> fail "alignment padding was not zeros" +-- | Read out n bytes as a @ByteString@, aligning to a 32-bit boundary before and+-- after.+bytestring :: NumBytes -> GetBits ByteString+bytestring n@(Bytes' nbytes) = do+ align32bits+ r <- GetBits+ $ \ !(# pos#, lim# #) ->+ \inp ->+ let !sbyte# = pos# `uncheckedIShiftRL#` 3# -- known to be aligned+ !endAt# = pos# +# bitCount# (bytesToBits n)+ !end# = (# endAt#, lim# #)+ err = "Sub-bytestring attempted beyond end of input bytestring"+ in if isTrue# (endAt# <=# lim#)+ then (# pure $ BS.take nbytes $ BS.drop (I# sbyte#) inp, end# #)+ else (# Left err, end# #)+ align32bits+ return r++ -- | Add a label to the error tag stack. label :: String -> GetBits a -> GetBits a-label l m = GetBits (\ off -> C.label l (unGetBits m off))+label l m = GetBits $ \ !pos# inp ->+ let !(# j, n# #) = unGetBits m pos# inp+ in case j of+ Left e -> (# Left $ e <> "\n " <> l, n# #)+ Right r -> (# Right r, n# #) --- | Isolate input length, in 32-bit words.-isolate :: Int -> GetBits a -> GetBits a-isolate ws m = GetBits (\ off -> C.isolate (ws * 4) (unGetBits m off)) +-- | Isolate input to a sub-span of the specified byte length.+isolate :: NumBytes -> GetBits a -> GetBits a+isolate ws m =+ GetBits $ \ !(# pos#, lim# #) ->+ \inp ->+ let !l# = pos# +# bitCount# (bytesToBits ws)+ !(# r, (# x#, _ #) #) = unGetBits m (# pos#, l# #) inp+ in (# r, (# x#, lim# #) #)++ -- | Try to parse something, returning Nothing when it fails.------ XXX this will hang on to the parsing state at the Get and GetBits levels, so--- a long-running computation will keep the current state until it finishes.+ try :: GetBits a -> GetBits (Maybe a) try m = (Just <$> m) `mplus` return Nothing -skip :: Int -> GetBits ()-skip n = do- _ <- fixed n- return ()++-- | Skips the specified number of bits++skip :: NumBits -> GetBits ()+skip !(Bits' (I# n#)) =+ GetBits $ \ !(# cur#, lim# #) ->+ let !newLoc# = cur# +# n#+ !newPos# = (# newLoc#, lim# #)+ in if isTrue# (newLoc# ># lim#)+ then \_ -> (# Left "skipped past end of bytestring"+ , newPos#+ #)+ else \_ -> (# Right (), newPos# #)
src/Data/LLVM/BitCode/IR.hs view
@@ -6,13 +6,14 @@ import Data.LLVM.BitCode.Bitstream import Data.LLVM.BitCode.BitString+import Data.LLVM.BitCode.IR.Blocks import Data.LLVM.BitCode.IR.Module (parseModuleBlock) import Data.LLVM.BitCode.Match import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record import Text.LLVM.AST -import Control.Monad ((<=<),unless)-import Data.Monoid (mappend)+import Control.Monad (unless,forM_) import Data.Word (Word16) @@ -20,11 +21,9 @@ -- | The magic number that identifies a @Bitstream@ structure as LLVM IR. llvmIrMagic :: Word16-llvmIrMagic = fromBitString (toBitString 8 0xc0 `mappend` toBitString 8 0xde)---- | Block selector for the top-level module block.-moduleBlock :: Match Entry [Entry]-moduleBlock = fmap blockEntries . hasBlockId 8 <=< block+llvmIrMagic = fromBitString (toBitString (Bits' 8) 0xc0+ `joinBitString`+ toBitString (Bits' 8) 0xde) -- | Parse an LLVM Module out of a Bitstream object. parseModule :: Bitstream -> Parse Module@@ -32,6 +31,16 @@ unless (bsAppMagic == llvmIrMagic) (fail "Bitstream is not an llvm-ir") parseTopLevel bsEntries +findTables :: [Entry] -> Parse ()+findTables es = forM_ es $ \e ->+ case e of+ (strtabBlockId -> Just [ abbrevDef -> Just _+ , abbrev -> Just (fromAbbrev -> Just r)+ ]) -> do+ st <- mkStrtab <$> parseField r 0 fieldBlob+ setStringTable st+ --(symtabBlockId -> Just _) -> fail "Found symbol table."+ _ -> return () -- | The only top-level block that we parse currently is the module block. The -- Identification block that's introduced in 3.8 is ignored. In the future, it@@ -39,7 +48,8 @@ -- aid error reporting. parseTopLevel :: [Entry] -> Parse Module -parseTopLevel (EntryBlock Block { blockId = 8, blockEntries } : _) =+parseTopLevel ((moduleBlockId -> Just blockEntries) : rest) = do+ findTables rest parseModuleBlock blockEntries parseTopLevel (_ : rest) =
src/Data/LLVM/BitCode/IR/Attrs.hs view
@@ -35,3 +35,13 @@ 18 -> return Linkonce 19 -> return LinkonceODR _ -> mzero++visibility :: Match Field Visibility+visibility = choose <=< numeric+ where+ choose :: Match Int Visibility+ choose n = case n of+ 0 -> return DefaultVisibility+ 1 -> return HiddenVisibility+ 2 -> return ProtectedVisibility+ _ -> mzero
src/Data/LLVM/BitCode/IR/Blocks.hs view
@@ -16,6 +16,7 @@ -- Module Block Ids ------------------------------------------------------------ +-- | Block selector for the top-level module block. moduleBlockId :: Match Entry [Entry] moduleBlockId = fmap blockEntries . hasBlockId 8 <=< block @@ -66,6 +67,18 @@ metadataKindBlockId :: Match Entry [Entry] metadataKindBlockId = fmap blockEntries . hasBlockId 22 <=< block +strtabBlockId :: Match Entry [Entry]+strtabBlockId = fmap blockEntries . hasBlockId 23 <=< block++ltoSummaryBlockId :: Match Entry [Entry]+ltoSummaryBlockId = fmap blockEntries . hasBlockId 24 <=< block++symtabBlockId :: Match Entry [Entry]+symtabBlockId = fmap blockEntries . hasBlockId 25 <=< block++syncScopeNamesBlockId :: Match Entry [Entry]+syncScopeNamesBlockId = fmap blockEntries . hasBlockId 26 <=< block+ -- Module Codes ---------------------------------------------------------------- -- | MODULE_CODE_VERSION@@ -127,3 +140,9 @@ moduleCodeIFunc :: Match Entry Record moduleCodeIFunc = hasRecordCode 18 <=< fromEntry++strtabBlobId :: Match Entry Record+strtabBlobId = hasRecordCode 1 <=< fromEntry++symtabBlobId :: Match Entry Record+symtabBlobId = hasRecordCode 1 <=< fromEntry
src/Data/LLVM/BitCode/IR/Constants.hs view
@@ -1,33 +1,38 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} module Data.LLVM.BitCode.IR.Constants where -import Data.LLVM.BitCode.Bitstream-import Data.LLVM.BitCode.IR.Values-import Data.LLVM.BitCode.Match-import Data.LLVM.BitCode.Parse-import Data.LLVM.BitCode.Record-import Text.LLVM.AST+import qualified Data.LLVM.BitCode.Assert as Assert+import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST -import Control.Monad (mplus,mzero,foldM,(<=<),when)-import Control.Monad.ST (runST,ST)-import Data.Array.ST (newArray,readArray,MArray,STUArray)-import Data.Bits (shiftL,shiftR,testBit)-import Data.Char (chr)-import Data.Maybe (fromMaybe)-import Data.Word (Word32,Word64)+import qualified Codec.Binary.UTF8.String as UTF8 (decode)+import Control.Monad (mplus,mzero,foldM,(<=<), when)+import Control.Monad.ST (runST,ST)+import Data.Array.ST (newArray,readArray,MArray,STUArray)+import Data.Bits (shiftL,shiftR,testBit, Bits)+import Data.LLVM.BitCode.BitString ( pattern Bits' )+import qualified Data.LLVM.BitCode.BitString as BitS import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Word (Word16, Word32,Word64) #if __GLASGOW_HASKELL__ >= 704-import Data.Array.Unsafe (castSTUArray)+import Data.Array.Unsafe (castSTUArray) #else-import Data.Array.ST (castSTUArray)+import Data.Array.ST (castSTUArray) #endif +import Prelude + -- Instruction Field Parsing --------------------------------------------------- -- | Parse a binop from a field, returning its constructor in the AST.@@ -129,6 +134,23 @@ choose 41 = return Isle choose _ = mzero +unopGeneric :: forall a.+ (UnaryArithOp -> Typed PValue -> a)+ -> Match Field (Typed PValue -> a)+unopGeneric uaop = choose <=< numeric+ where+ choose :: Match Int (Typed PValue -> a)+ choose 0 = return (uaop FNeg)+ choose _ = mzero++unop :: Match Field (Typed PValue -> PInstr)+unop = unopGeneric UnaryArith++unopCE :: Match Field (Typed PValue -> PValue)+unopCE = unopGeneric uaop+ where+ uaop op tv = ValConstExpr (ConstUnaryArith op tv)+ castOpGeneric :: forall c. (ConvOp -> Maybe c) -> Match Field c castOpGeneric op = choose <=< numeric where@@ -212,21 +234,23 @@ -- [n x value] 5 -> label "CST_CODE_WIDE_INTEGER" $ do ty <- getTy- n <- parseWideInteger r+ n <- parseWideInteger r 0 return (getTy, Typed ty (ValInteger n):cs) -- [fpval] 6 -> label "CST_CODE_FLOAT" $ do- let field = parseField r ty <- getTy ft <- (elimFloatType =<< elimPrimType ty) `mplus` fail "expecting a float type"- let build k = do- w <- field 0 numeric- return (getTy, (Typed ty $! k w):cs)+ let build :: (Num a, Bits a) => (a -> PValue) -> Parse (Parse Type, [Typed PValue])+ build k = do+ a <- parseField r 0 (fmap k . numeric)+ return (getTy, (Typed ty $! a):cs) case ft of Float -> build (ValFloat . castFloat)- _ -> build (ValDouble . castDouble)+ Double -> build (ValDouble . castDouble)+ X86_fp80 -> fp80build ty r cs getTy+ _ -> error $ "parseConstantEntry: Unsupported type " ++ show ft -- [n x value number] 7 -> label "CST_CODE_AGGREGATE" $ do@@ -255,15 +279,15 @@ 8 -> label "CST_CODE_STRING" $ do let field = parseField r ty <- getTy- values <- field 0 string+ values <- field 0 (fieldArray char) return (getTy, Typed ty (ValString values):cs) -- [values] 9 -> label "CST_CODE_CSTRING" $ do ty <- getTy- values <- parseField r 0 cstring+ values <- parseField r 0 (fieldArray (fieldChar6 ||| char)) `mplus` parseFields r 0 (fieldChar6 ||| char)- return (getTy, Typed ty (ValString (values ++ [chr 0])):cs)+ return (getTy, Typed ty (ValString (values ++ [0])):cs) -- [opcode,opval,opval] 10 -> label "CST_CODE_CE_BINOP" $ do@@ -292,7 +316,7 @@ -- [n x operands] 12 -> label "CST_CODE_CE_GEP" $ do ty <- getTy- v <- parseCeGep False t r+ v <- parseCeGep CeGepCode12 t r return (getTy,Typed ty v:cs) -- [opval,opval,opval]@@ -320,9 +344,12 @@ -- [opty, opval, opval, pred] 17 -> label "CST_CODE_CE_CMP" $ do let field = parseField r- opty <- getType =<< field 0 numeric- op0 <- getConstantFwdRef t opty =<< field 1 numeric- op1 <- getConstantFwdRef t opty =<< field 2 numeric+ opty <- getType =<< field 0 numeric+ ix0 <- field 1 numeric+ ix1 <- field 2 numeric+ cxt <- getContext+ let op0 = forwardRef cxt ix0 t+ let op1 = forwardRef cxt ix1 t let isFloat = isPrimTypeOf isFloatingPoint cst <- if isFloat opty || isVectorOf isFloat opty@@ -335,19 +362,8 @@ return (getTy, Typed (PrimType (Integer 1)) (ValConstExpr cst):cs) 18 -> label "CST_CODE_INLINEASM_OLD" $ do- let field = parseField r- ty <- getTy- flags <- field 0 numeric- let sideEffect = testBit (flags :: Int) 0- alignStack = (flags `shiftR` 1) == 1-- alen <- field 1 numeric- asm <- parseSlice r 2 alen char-- clen <- field (2+alen) numeric- cst <- parseSlice r (3+alen) clen char-- return (getTy, Typed ty (ValAsm sideEffect alignStack asm cst):cs)+ tv <- parseInlineAsm InlineAsmCode18 getTy r+ return (getTy, tv:cs) 19 -> label "CST_CODE_CE_SHUFFLEVEC_EX" $ do notImplemented@@ -355,19 +371,20 @@ -- [n x operands] 20 -> label "CST_CODE_CE_INBOUNDS_GEP" $ do ty <- getTy- v <- parseCeGep True t r+ v <- parseCeGep CeGepCode20 t r return (getTy,Typed ty v:cs) -- [funty,fnval,bb#] 21 -> label "CST_CODE_BLOCKADDRESS" $ do+ when (length (recordFields r) < 3) $+ fail "Invalid BLOCKADDRESS record (length < 3)" let field = parseField r ty <- getTy- val <- getValue ty =<< field 1 numeric- bid <- field 2 numeric- sym <- elimValSymbol (typedValue val)- `mplus` fail "invalid function symbol in BLOCKADDRESS record"- let ce = ConstBlockAddr sym bid- return (getTy, Typed ty (ValConstExpr ce):cs)+ ctx <- getContext+ valref <- field 1 numeric+ bid <- field 2 numeric+ let ce = ConstBlockAddr (forwardRef ctx valref t) bid+ return (getTy, Typed ty (ValConstExpr ce) : cs) -- [n x elements] 22 -> label "CST_CODE_DATA" $ do@@ -381,44 +398,53 @@ | otherwise = ValVector (PrimType elemTy) elems return (getTy, Typed ty val : cs) case elemTy of- Integer 8 -> build ValInteger- Integer 16 -> build ValInteger- Integer 32 -> build ValInteger- Integer 64 -> build ValInteger- FloatType Float -> build ValFloat- FloatType Double -> build ValDouble- _ -> fail "unknown element type in CE_DATA"-- 23 -> label "CST_CODE_INLINEASM" $ do- let field = parseField r- mask <- field 0 numeric-- let test = testBit (mask :: Word32)- hasSideEffects = test 0- isAlignStack = test 1- _asmDialect = mask `shiftR` 2+ Integer 8 -> build ValInteger+ Integer 16 -> build ValInteger+ Integer 32 -> build ValInteger+ Integer 64 -> build ValInteger+ FloatType Float -> build (ValFloat . castFloat)+ FloatType Double -> build (ValDouble . castDouble)+ x -> Assert.unknownEntity "element type" x - let len = length (recordFields r)- asmStrSize <- field 1 numeric- when (2 + asmStrSize >= len)- (fail "Invalid record")+ 23 -> label "CST_CODE_INLINEASM_OLD2" $ do+ tv <- parseInlineAsm InlineAsmCode23 getTy r+ return (getTy, tv:cs) - constStrSize <- field (2 + asmStrSize) numeric- when (3 + asmStrSize + constStrSize > len)- (fail "Invalid record")+ -- [opty, flags, n x operands]+ 24 -> label "CST_CODE_CE_GEP_WITH_INRANGE_INDEX" $ do+ ty <- getTy+ v <- parseCeGep CeGepCode24 t r+ return (getTy,Typed ty v:cs) - asmStr <- parseSlice r 2 asmStrSize char- constStr <- parseSlice r (3 + asmStrSize) constStrSize char+ -- [opcode, opval]+ 25 -> label "CST_CODE_CE_UNOP" $ do+ let field = parseField r+ ty <- getTy+ mkInstr <- field 0 unopCE+ opval <- field 1 numeric+ cxt <- getContext+ let v = forwardRef cxt opval t+ return (getTy, Typed ty (mkInstr v) : cs) + 26 -> label "CST_CODE_POISON" $ do ty <- getTy- let val = ValAsm hasSideEffects isAlignStack asmStr constStr+ return (getTy, Typed ty ValPoison : cs) - return (getTy, Typed ty val : cs)+ 27 -> label "CST_CODE_DSO_LOCAL_EQUIVALENT" $ do+ notImplemented + 28 -> label "CST_CODE_INLINEASM_OLD3" $ do+ tv <- parseInlineAsm InlineAsmCode28 getTy r+ return (getTy, tv:cs) + 29 -> label "CST_CODE_NO_CFI_VALUE" $ do+ notImplemented + 30 -> label "CST_CODE_INLINEASM" $ do+ tv <- parseInlineAsm InlineAsmCode30 getTy r+ return (getTy, tv:cs) - code -> fail ("unknown constant record code: " ++ show code)+ code -> Assert.unknownEntity "constant record code" code parseConstantEntry _ st (abbrevDef -> Just _) = -- ignore abbreviation definitions@@ -427,27 +453,66 @@ parseConstantEntry _ _ e = fail ("constant block: unexpected: " ++ show e) -parseCeGep :: Bool -> ValueTable -> Record -> Parse PValue-parseCeGep isInbounds t r = do- let isExplicit = odd (length (recordFields r))- firstIdx = if isExplicit then 1 else 0- field = parseField r- loop n = do+-- | The different codes for constant @getelementptr@ expressions. Each one has+-- minor differences in how they are parsed.+data CeGepCode+ = CeGepCode12+ -- ^ @CST_CODE_CE_GEP = 12@. The original.+ | CeGepCode20+ -- ^ @CST_CODE_CE_INBOUNDS_GEP = 20@. This adds an @inbounds@ field that+ -- indicates that the result value should be poison if it performs an+ -- out-of-bounds index.+ | CeGepCode24+ -- ^ @CST_CODE_CE_GEP_WITH_INRANGE_INDEX = 24@. This adds an @inrange@ field+ -- that indicates that loading or storing to the result pointer will have+ -- undefined behavior if the load or store would access memory outside of the+ -- bounds of the indices marked as @inrange@.+ deriving Eq++-- | Parse a 'ConstGEP' value. There are several variations on this theme that+-- are captured in the 'CeGepCode' argument.+parseCeGep :: CeGepCode -> ValueTable -> Record -> Parse PValue+parseCeGep code t r = do+ let field = parseField r++ (mbBaseTy, ix0) <-+ if code == CeGepCode24 || odd (length (recordFields r))+ then do baseTy <- getType =<< field 0 numeric+ pure (Just baseTy, 1)+ else pure (Nothing, 0)++ (isInbounds, mInrangeIdx, ix1) <-+ case code of+ CeGepCode12 -> pure (False, Nothing, ix0)+ CeGepCode20 -> pure (True, Nothing, ix0)+ CeGepCode24 -> do+ (flags :: Word64) <- parseField r ix0 numeric+ let inbounds = testBit flags 0+ inrangeIdx = flags `shiftR` 1+ pure (inbounds, Just inrangeIdx, ix0 + 1)++ let loop n = do ty <- getType =<< field n numeric elt <- field (n+1) numeric rest <- loop (n+2) `mplus` return [] cxt <- getContext return (Typed ty (typedValue (forwardRef cxt elt t)) : rest)- mPointeeType <-- if isExplicit- then Just <$> (getType =<< field 0 numeric)- else pure Nothing- args <- loop firstIdx- return $! ValConstExpr (ConstGEP isInbounds mPointeeType args)+ args <- loop ix1+ (ptr, args') <-+ case args of+ [] -> fail "Invalid constant GEP with no operands"+ (base:args') -> pure (base, args') -parseWideInteger :: Record -> Parse Integer-parseWideInteger r = do- limbs <- parseFields r 0 signedWord64+ baseTy <-+ case mbBaseTy of+ Just baseTy -> pure baseTy+ Nothing -> Assert.elimPtrTo "constant GEP not headed by pointer" (typedType ptr)++ return $! ValConstExpr (ConstGEP isInbounds mInrangeIdx baseTy ptr args')++parseWideInteger :: Record -> Int -> Parse Integer+parseWideInteger r idx = do+ limbs <- parseSlice r idx (length (recordFields r) - idx) signedWord64 return (foldr (\l acc -> acc `shiftL` 64 + (toInteger l)) 0 limbs) resolveNull :: Type -> Parse PValue@@ -455,7 +520,62 @@ HasNull nv -> return nv ResolveNull i -> resolveNull =<< getType' =<< getTypeId i +-- | The different codes for inline @asm@ constants. Each one has minor+-- differences in how they are parsed.+data InlineAsmCode+ = InlineAsmCode18+ -- ^ @CST_CODE_INLINEASM_OLD = 18@. The original.+ | InlineAsmCode23+ -- ^ @CST_CODE_INLINEASM_OLD2 = 23@. This adds an @asmdialect@ field.+ | InlineAsmCode28+ -- ^ @CST_CODE_INLINEASM_OLD3 = 28@. This adds an @unwind@ field (which is+ -- referred to as @canThrow@ in the LLVM source code).+ | InlineAsmCode30+ -- ^ @CST_CODE_INLINEASM = 30@. This adds an explicit function type field. +-- | Parse a 'ValAsm' value. There are several variations on this theme that are+-- captured in the 'InlineAsmCode' argument.+parseInlineAsm :: InlineAsmCode -> Parse Type -> Record -> Parse (Typed PValue)+parseInlineAsm code getTy r = do+ let field = parseField r++ -- If using InlineAsmCode30 or later, we parse the type as an explicit+ -- field.+ let parseTy = do ty <- getType =<< field 0 numeric+ return (PtrTo ty, 1)+ -- If using an older InlineAsmCode, then we retrieve the type from the+ -- current context.+ let useCurTy = do ty <- getTy+ return (ty, 0)+ (ty, ix) <- case code of+ InlineAsmCode18 -> useCurTy+ InlineAsmCode23 -> useCurTy+ InlineAsmCode28 -> useCurTy+ InlineAsmCode30 -> parseTy++ mask <- field ix numeric++ let test = testBit (mask :: Word32)+ hasSideEffects = test 0+ isAlignStack = test 1+ -- We don't store these in the llvm-pretty AST at the moment:+ _asmDialect = test 2 -- Only with InlineAsmCode23 or later+ _canThrow = test 3 -- Only with InlineAsmCode28 or later++ asmStrSize <- field (ix + 1) numeric+ Assert.recordSizeGreater r (ix + 1 + asmStrSize)++ constStrSize <- field (ix + 2 + asmStrSize) numeric+ Assert.recordSizeGreater r (ix + 2 + asmStrSize + constStrSize)++ asmStr <- fmap UTF8.decode $ parseSlice r (ix + 2) asmStrSize char+ constStr <- fmap UTF8.decode $ parseSlice r (ix + 3 + asmStrSize) constStrSize char++ let val = ValAsm hasSideEffects isAlignStack asmStr constStr++ return (Typed ty val)++ -- Float/Double Casting -------------------------------------------------------- castFloat :: Word32 -> Float@@ -470,3 +590,41 @@ arr <- newArray (0 :: Int, 0) x 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).+--+-- 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).+--+-- 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+-- 80... extras are ignored). Bits are not stored in the expected way+-- and "compensation" is needed. First the two record fields are+-- combined into an 80-bit integer (see+-- LGH/lib/Bitcode/Reader/BitcodeReader.cpp:2196-2202), using only 64+-- bits of the first field and 16 bits of the second field, discarding+-- the extra bits. This is the result of this build operation; if+-- this result is used semantically, it should be analyzed as per+-- LGH/lib/Support/APFloat.cpp:3076-3108.++fp80build :: Type -> Record -> [Typed PValue] -> Parse Type+ -> Parse (Parse Type, [Typed PValue])+fp80build ty r cs getTy =+ do v1 <- parseField r 0 fieldLiteral+ v2 <- parseField r 1 fieldLiteral+ let -- Note bs1 <> bs2 results in bs2|bs1 layout, shifting bs2 to higher bits+ v64_0 = BitS.take (Bits' 64)+ $ BitS.take (Bits' 16) v2 `BitS.joinBitString` v1+ v64_1 = BitS.drop (Bits' 48) v2+ -- result is v64_1|v64_0 being v0|v1+ fullexp :: Word16+ fullexp = BitS.fromBitString $ BitS.take (Bits' 16) v64_1 -- includes sign bit+ significnd :: Word64+ significnd = BitS.fromBitString $ v64_0+ fp80Val = FP80_LongDouble fullexp significnd+ return (getTy, Typed ty (ValFP80 fp80Val):cs)
src/Data/LLVM/BitCode/IR/Function.hs view
@@ -1,64 +1,117 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Data.LLVM.BitCode.IR.Function where -import Data.LLVM.BitCode.Bitstream-import Data.LLVM.BitCode.IR.Blocks-import Data.LLVM.BitCode.IR.Constants-import Data.LLVM.BitCode.IR.Metadata-import Data.LLVM.BitCode.IR.Values-import Data.LLVM.BitCode.Match-import Data.LLVM.BitCode.Parse-import Data.LLVM.BitCode.Record-import Text.LLVM.AST-import Text.LLVM.Labels-import Text.LLVM.PP+import qualified Data.LLVM.BitCode.Assert as Assert+import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.IR.Blocks+import Data.LLVM.BitCode.IR.Constants+import Data.LLVM.BitCode.IR.Metadata+import Data.LLVM.BitCode.IR.Values+import Data.LLVM.BitCode.IR.Attrs+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record -import Control.Applicative ((<$>),(<*>))-import Control.Monad (unless,mplus,mzero,foldM,(<=<))-import Data.Bits (shiftR,bit,shiftL,testBit,(.&.),(.|.),complement)-import Data.Int (Int32)-import Data.Word (Word32)+import Text.LLVM.AST+import Text.LLVM.Labels+import Text.LLVM.PP++import Control.Monad (when,unless,mplus,mzero,foldM,(<=<))+import Data.Bits (shiftR,bit,shiftL,testBit,(.&.),(.|.),complement,Bits)+import Data.Int (Int32)+import Data.Word (Word32) import qualified Data.Foldable as F+import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Traversable as T +-- | When showing a Symbol to the user, show it in the manner that it would appear+-- in LLVM text format. This displays the Symbol in the format associated with+-- the latest version of LLVM supported by llvm-pretty and this library; the+-- Symbol syntax has not changed from LLVM 3.5 through LLVM 16, and this library+-- is intended to be able to import *any* version of LLVM, so this is not a+-- significant issue that would drive the code changes necessary to make an+-- actual LLVM version available here.++-- NOTE: this cannot be eta-reduced to point-free format because simplified+-- subsumption rules (introduced in GHC 9) requires eta-expansion of some higher+-- order functions in order to maintain soundness and typecheck.+prettySym :: Symbol -> String+prettySym s = show $ ppLLVM llvmVlatest $ llvmPP s++ -- Function Aliases ------------------------------------------------------------ type AliasList = Seq.Seq PartialAlias data PartialAlias = PartialAlias- { paName :: Symbol- , paType :: Type- , paTarget :: !Int+ { paLinkage :: Maybe Linkage+ , paVisibility :: Maybe Visibility+ , paName :: Symbol+ , paType :: Type+ , paTarget :: !Word32 } deriving Show -parseAlias :: Int -> Record -> Parse PartialAlias-parseAlias n r = do+parseAliasOld :: Int -> Record -> Parse PartialAlias+parseAliasOld n r = do+ sym <- entryName n let field = parseField r+ name = Symbol sym ty <- getType =<< field 0 numeric tgt <- field 1 numeric- sym <- entryName n- let name = Symbol sym+ lnk <- field 2 linkage+ vis <- field 3 visibility _ <- pushValue (Typed ty (ValSymbol name)) return PartialAlias- { paName = name- , paType = ty- , paTarget = tgt+ { paLinkage = Just lnk+ , paVisibility = Just vis+ , paName = name+ , paType = ty+ , paTarget = tgt } +parseAlias :: Record -> Parse PartialAlias+parseAlias r = do+ n <- nextValueId+ (name, offset) <- oldOrStrtabName n r+ let field i = parseField r (i + offset)+ ty <- getType =<< field 0 numeric+ _addrSp <- field 1 unsigned+ tgt <- field 2 numeric+ lnk <- field 3 linkage+ vis <- field 4 visibility+++ -- XXX: is it the case that the alias type will always be a pointer to the+ -- aliasee?+ _ <- pushValue (Typed (PtrTo ty) (ValSymbol name))++ return PartialAlias+ { paLinkage = Just lnk+ , paVisibility = Just vis+ , paName = name+ , paType = ty+ , paTarget = tgt+ }+ finalizePartialAlias :: PartialAlias -> Parse GlobalAlias-finalizePartialAlias pa = do- tv <- getValue (paType pa) (paTarget pa)- tgt <- relabel (const requireBbEntryName) (typedValue tv)+finalizePartialAlias pa = label "finalizePartialAlias" $ do+ -- aliases refer to absolute offsets+ tv <- getFnValueById (paType pa) (fromIntegral (paTarget pa))+ tgt <- liftFinalize $ relabel (const requireBbEntryName) (typedValue tv) return GlobalAlias- { aliasName = paName pa- , aliasType = paType pa- , aliasTarget = tgt+ { aliasLinkage = paLinkage pa+ , aliasVisibility = paVisibility pa+ , aliasName = paName pa+ , aliasType = paType pa+ , aliasTarget = tgt } @@ -70,11 +123,14 @@ finalizeDeclare :: FunProto -> Parse Declare finalizeDeclare fp = case protoType fp of PtrTo (FunTy ret args va) -> return Declare- { decRetType = ret- , decName = Symbol (protoName fp)- , decArgs = args- , decVarArgs = va- , decAttrs = []+ { decLinkage = protoLinkage fp+ , decVisibility = protoVisibility fp+ , decRetType = ret+ , decName = protoSym fp+ , decArgs = args+ , decVarArgs = va+ , decAttrs = []+ , decComdat = protoComdat fp } _ -> fail "invalid type on function prototype" @@ -86,20 +142,22 @@ -- | A define with a list of statements for a body, instead of a list of basic -- bocks. data PartialDefine = PartialDefine- { partialLinkage :: Maybe Linkage- , partialGC :: Maybe GC- , partialSection :: Maybe String- , partialRetType :: Type- , partialName :: Symbol- , partialArgs :: [Typed Ident]- , partialVarArgs :: Bool- , partialBody :: BlockList- , partialBlock :: StmtList- , partialBlockId :: !Int- , partialSymtab :: ValueSymtab- , partialMetadata :: Map.Map PKindMd PValMd- , partialGlobalMd :: [PartialUnnamedMd]- } deriving (Show)+ { partialLinkage :: Maybe Linkage+ , partialVisibility :: Maybe Visibility+ , partialGC :: Maybe GC+ , partialSection :: Maybe String+ , partialRetType :: Type+ , partialName :: Symbol+ , partialArgs :: [Typed Ident]+ , partialVarArgs :: Bool+ , partialBody :: BlockList+ , partialBlock :: StmtList+ , partialBlockId :: !Int+ , partialSymtab :: ValueSymtab+ , partialMetadata :: Map.Map PKindMd PValMd+ , partialGlobalMd :: !(Seq.Seq PartialUnnamedMd)+ , partialComdatName :: Maybe String+ } deriving Show -- | Generate a partial function definition from a function prototype. emptyPartialDefine :: FunProto -> Parse PartialDefine@@ -111,19 +169,21 @@ symtab <- initialPartialSymtab return PartialDefine- { partialLinkage = protoLinkage proto- , partialGC = protoGC proto- , partialSection = protoSect proto- , partialRetType = rty- , partialName = Symbol (protoName proto)- , partialArgs = zipWith Typed tys names- , partialVarArgs = va- , partialBody = Seq.empty- , partialBlock = Seq.empty- , partialBlockId = 0- , partialSymtab = symtab- , partialMetadata = Map.empty- , partialGlobalMd = []+ { partialLinkage = protoLinkage proto+ , partialVisibility = protoVisibility proto+ , partialGC = protoGC proto+ , partialSection = protoSect proto+ , partialRetType = rty+ , partialName = protoSym proto+ , partialArgs = zipWith Typed tys names+ , partialVarArgs = va+ , partialBody = mempty+ , partialBlock = mempty+ , partialBlockId = 0+ , partialSymtab = symtab+ , partialMetadata = mempty+ , partialGlobalMd = mempty+ , partialComdatName = protoComdat proto } -- | Set the statement list in a partial define.@@ -136,7 +196,7 @@ initialPartialSymtab :: Parse ValueSymtab initialPartialSymtab = do- mb <- bbEntryName 0+ mb <- liftFinalize $ bbEntryName 0 case mb of Just{} -> return emptyValueSymtab Nothing -> do@@ -162,45 +222,48 @@ -type BlockLookup = Symbol -> Int -> Parse BlockLabel+type BlockLookup = Symbol -> Int -> Finalize BlockLabel lookupBlockName :: DefineList -> BlockLookup lookupBlockName dl = lkp where syms = Map.fromList [ (partialName d, partialSymtab d) | d <- F.toList dl ] lkp fn bid = case Map.lookup fn syms of- Nothing -> fail ("symbol " ++ show (ppLLVM (ppSymbol fn)) ++ " is not defined")- Just st -> case Map.lookup (SymTabBBEntry bid) st of+ Nothing -> fail ("symbol " ++ prettySym fn ++ " is not defined")+ Just st -> case IntMap.lookup bid (bbSymtab st) of Nothing -> fail ("block id " ++ show bid ++ " does not exist") Just sn -> return (mkBlockLabel sn) -- | Finalize a partial definition. finalizePartialDefine :: BlockLookup -> PartialDefine -> Parse Define finalizePartialDefine lkp pd =+ label "finalizePartialDefine" $ -- augment the symbol table with implicitly named anonymous blocks, and -- generate basic blocks. withValueSymtab (partialSymtab pd) $ do- body <- finalizeBody lkp (partialBody pd)+ body <- liftFinalize $ finalizeBody lkp (partialBody pd) md <- finalizeMetadata (partialMetadata pd) return Define- { defLinkage = partialLinkage pd- , defGC = partialGC pd- , defAttrs = []- , defRetType = partialRetType pd- , defName = partialName pd- , defArgs = partialArgs pd- , defVarArgs = partialVarArgs pd- , defBody = body- , defSection = partialSection pd- , defMetadata = md+ { defLinkage = partialLinkage pd+ , defVisibility = partialVisibility pd+ , defGC = partialGC pd+ , defAttrs = []+ , defRetType = partialRetType pd+ , defName = partialName pd+ , defArgs = partialArgs pd+ , defVarArgs = partialVarArgs pd+ , defBody = body+ , defSection = partialSection pd+ , defMetadata = md+ , defComdat = partialComdatName pd } finalizeMetadata :: PFnMdAttachments -> Parse FnMdAttachments finalizeMetadata patt = Map.fromList <$> mapM f (Map.toList patt)- where f (k,md) = (,) <$> getKind k <*> finalizePValMd md+ where f (k,md) = (,) <$> getKind k <*> liftFinalize (finalizePValMd md) -- | Individual label resolution step.-resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Parse BlockLabel+resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Finalize BlockLabel resolveBlockLabel lkp mbSym = case mbSym of Nothing -> requireBbEntryName Just sym -> lkp sym@@ -235,7 +298,7 @@ terminateBlock :: PartialDefine -> Parse PartialDefine terminateBlock d = do let next = partialBlockId d + 1- mb <- bbEntryName next+ mb <- liftFinalize $ bbEntryName next d' <- case mb of Just _ -> return d Nothing -> do@@ -255,7 +318,7 @@ type BlockList = Seq.Seq PartialBlock -- | Process a @BlockList@, turning it into a list of basic blocks.-finalizeBody :: BlockLookup -> BlockList -> Parse [BasicBlock]+finalizeBody :: BlockLookup -> BlockList -> Finalize [BasicBlock] finalizeBody lkp = fmap F.toList . T.mapM (finalizePartialBlock lkp) data PartialBlock = PartialBlock@@ -267,7 +330,7 @@ setPartialStmts stmts pb = pb { partialStmts = stmts } -- | Process a partial basic block into a full basic block.-finalizePartialBlock :: BlockLookup -> PartialBlock -> Parse BasicBlock+finalizePartialBlock :: BlockLookup -> PartialBlock -> Finalize BasicBlock finalizePartialBlock lkp pb = BasicBlock <$> bbEntryName (partialLabel pb) <*> finalizeStmts lkp (partialStmts pb)@@ -278,15 +341,21 @@ -- | Process a list of statements with explicit block id labels into one with -- textual labels.-finalizeStmts :: BlockLookup -> StmtList -> Parse [Stmt]+finalizeStmts :: BlockLookup -> StmtList -> Finalize [Stmt] finalizeStmts lkp = mapM (finalizeStmt lkp) . F.toList -finalizeStmt :: BlockLookup -> Stmt' Int -> Parse Stmt+finalizeStmt :: BlockLookup -> Stmt' Int -> Finalize Stmt finalizeStmt lkp = relabel (resolveBlockLabel lkp) -- Function Block Parsing ------------------------------------------------------ +-- | A bit saying whether a call or callbr instruction has an explicit type, see+-- LLVM's CallMarkersFlags:+-- https://github.com/llvm/llvm-project/blob/c8ed784ee69a7dbdf4b33e85229457ffad309cf2/llvm/include/llvm/Bitcode/LLVMBitCodes.h#L505+callExplicitTypeBit :: Int+callExplicitTypeBit = 15+ -- | Parse the function block. parseFunctionBlock :: Int {- ^ unnamed globals so far -} ->@@ -300,12 +369,12 @@ mb <- match (findMatch valueSymtabBlockId) ents case mb of Just es -> parseValueSymbolTableBlock es- Nothing -> return Map.empty+ Nothing -> return mempty -- pop the function prototype off of the internal stack proto <- popFunProto - label (protoName proto) $ withValueSymtab symtab $ do+ label (prettySym (protoSym proto)) $ withValueSymtab symtab $ do -- generate the initial partial definition pd <- emptyPartialDefine proto@@ -313,7 +382,7 @@ vt <- getValueTable -- merge the symbol table with the anonymous symbol table- return pd' { partialSymtab = partialSymtab pd' `Map.union` symtab }+ return pd' { partialSymtab = partialSymtab pd' `mappend` symtab } -- | Parse the members of the function block parseFunctionBlockEntry ::@@ -329,17 +398,29 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of -- [n]- 1 -> label "FUNC_CODE_DECLARE_BLOCKS" (return d)+ 1 -> label "FUNC_CODE_DECLARE_BLOCKS"+ (Assert.recordSizeGreater r 0 >> return d) -- [opval,ty,opval,opcode] 2 -> label "FUNC_CODE_INST_BINOP" $ do let field = parseField r (lhs,ix) <- getValueTypePair t r 0- rhs <- getValue (typedType lhs) =<< field ix numeric+ rhs <- getValue t (typedType lhs) =<< field ix numeric mkInstr <- field (ix + 1) binop- -- if there's an extra field on the end of the record, it's for designating- -- the value of the nuw and nsw flags. the constructor returned from binop- -- will use that value when constructing the binop.+ -- If there's an extra field on the end of the record, it's for one of the+ -- following:+ --+ -- - If the instruction is add, sub, mul, or shl, the extra field+ -- designates the value of the nuw and nsw flags.+ --+ -- - If the instruction is sdiv, udiv, lshr, or ashr, the extra field+ -- designates the value of the exact flag.+ --+ -- - If the instruction is floating-point, the extra field designates the+ -- value of the fast-math flags. We currently ignore these.+ --+ -- The constructor returned from binop will use that value when+ -- constructing the binop. let mbWord = numeric =<< fieldAt (ix + 2) r result (typedType lhs) (mkInstr mbWord lhs (typedValue rhs)) d @@ -347,6 +428,7 @@ 3 -> label "FUNC_CODE_INST_CAST" $ do let field = parseField r (tv,ix) <- getValueTypePair t r 0+ Assert.recordSizeIn r [ix + 2] resty <- getType =<< field ix numeric cast' <- field (ix+1) castOp result resty (cast' tv resty) d@@ -357,14 +439,14 @@ 5 -> label "FUNC_CODE_INST_SELECT" $ do let field = parseField r (tval,ix) <- getValueTypePair t r 0- fval <- getValue (typedType tval) =<< field ix numeric- cond <- getValue (PrimType (Integer 1)) =<< field (ix+1) numeric+ fval <- getValue t (typedType tval) =<< field ix numeric+ cond <- getValue t (PrimType (Integer 1)) =<< field (ix+1) numeric result (typedType tval) (Select cond tval (typedValue fval)) d -- [ty,opval,opval] 6 -> label "FUNC_CODE_INST_EXTRACTELT" $ do (tv,ix) <- getValueTypePair t r 0- idx <- getValue (PrimType (Integer 32)) =<< parseField r ix numeric+ idx <- getValue t (PrimType (Integer 32)) =<< parseField r ix numeric (_, ty) <- elimVector (typedType tv) `mplus` fail "invalid EXTRACTELT record" result ty (ExtractElt tv (typedValue idx)) d@@ -375,17 +457,21 @@ (tv,ix) <- getValueTypePair t r 0 (_,pty) <- elimVector (typedType tv) `mplus` fail "invalid INSERTELT record (not a vector)"- elt <- getValue pty =<< field ix numeric- idx <- getValue (PrimType (Integer 32)) =<< field (ix+1) numeric+ elt <- getValue t pty =<< field ix numeric+ idx <- getValue t (PrimType (Integer 32)) =<< field (ix+1) numeric result (typedType tv) (InsertElt tv elt (typedValue idx)) d -- [opval,ty,opval,opval] 8 -> label "FUNC_CODE_INST_SHUFFLEVEC" $ do let field = parseField r (vec1,ix) <- getValueTypePair t r 0- vec2 <- getValue (typedType vec1) =<< field ix numeric+ vec2 <- getValue t (typedType vec1) =<< field ix numeric (mask,_) <- getValueTypePair t r (ix+1)- result (typedType vec1) (ShuffleVector vec1 (typedValue vec2) mask) d+ resTy <- case (typedType vec1,typedType mask) of+ (Vector _ elemTy, Vector shuffleLen _) ->+ return (Vector shuffleLen elemTy)+ _ -> fail "Invalid arguments to shuffle vector (not vectors)"+ result resTy (ShuffleVector vec1 (typedValue vec2) mask) d -- 9 is handled lower down, as it's processed the same way as 28 @@ -393,18 +479,20 @@ 10 -> label "FUNC_CODE_INST_RET" $ case length (recordFields r) of 0 -> effect RetVoid d _ -> do- (tv,_) <- getValueTypePair t r 0+ (tv, ix) <- getValueTypePair t r 0+ Assert.recordSizeIn r [ix] effect (Ret tv) d -- [bb#,bb#,cond] or [bb#] 11 -> label "FUNC_CODE_INST_BR" $ do+ Assert.recordSizeIn r [1, 3] let field = parseField r bb1 <- field 0 numeric let jump = effect (Jump bb1) d branch = do bb2 <- field 1 numeric n <- field 2 numeric- cond <- getValue (PrimType (Integer 1)) n+ cond <- getValue t (PrimType (Integer 1)) n effect (Br cond bb1 bb2) d branch `mplus` jump @@ -425,9 +513,9 @@ PrimType (Integer w) -> return w _ -> fail "invalid switch discriminate" - cond <- getValue opty =<< field 2 numeric- def <- field 3 numeric -- Int id of a label- numCases <- field 4 numeric+ cond <- getValue t opty =<< field 2 numeric+ def <- field 3 numeric -- Int id of a label+ numCases <- field 4 numeric ls <- parseNewSwitchLabels width r numCases 5 effect (Switch cond def ls) d @@ -437,8 +525,8 @@ -- [opty, op0, op1, ...] let oldSwitch = do opty <- getType n- cond <- getValue opty =<< field 1 numeric- def <- field 2 numeric+ cond <- getValue t opty =<< field 1 numeric+ def <- field 2 numeric ls <- parseSwitchLabels opty r 3 effect (Switch cond def ls) d @@ -452,15 +540,33 @@ -- [attrs,cc,normBB,unwindBB,fnty,op0,op1..] 13 -> label "FUNC_CODE_INST_INVOKE" $ do+ Assert.recordSizeGreater r 3 let field = parseField r+ ccinfo <- field 1 unsigned normal <- field 2 numeric unwind <- field 3 numeric- (f,ix) <- getValueTypePair t r 4- (ret,as,va) <- elimFunPtr (typedType f)++ -- explicit function type?+ (mbFTy,ix) <-+ if testBit ccinfo 13+ then do ty <- getType =<< field 4 numeric+ return (Just ty, 5)+ else return (Nothing, 4)++ (f,ix') <- getValueTypePair t r ix++ fty <- case mbFTy of+ Just ty -> return ty+ Nothing -> Assert.elimPtrTo "Callee is not a pointer" (typedType f)++ (ret,as,va) <- elimFunTy fty `mplus` fail "invalid INVOKE record"- args <- parseInvokeArgs t va r ix as- result ret (Invoke (typedType f) (typedValue f) args normal unwind) d + args <- parseInvokeArgs t va r ix' as+ -- Use `fty` instead of `typedType f` as the function type, as `typedType f`+ -- will be a pointer type. See Note [Typing function applications].+ result ret (Invoke fty (typedValue f) args normal unwind) d+ 14 -> label "FUNC_CODE_INST_UNWIND" (effect Unwind d) 15 -> label "FUNC_CODE_INST_UNREACHABLE" (effect Unreachable d)@@ -474,6 +580,10 @@ -- cause a loop. useRelIds <- getRelIds args <- parsePhiArgs useRelIds t r++ when (even (length (recordFields r))) $ do+ pure () -- TODO: fast math flags+ result ty (Phi ty args) d -- 17 is unused@@ -481,8 +591,8 @@ -- [instty,opty,op,align] 19 -> label "FUNC_CODE_INST_ALLOCA" $ do- unless (length (recordFields r) == 4)- (fail "Invalid ALLOCA record")+ Assert.recordSizeIn r [4]+ let field = parseField r instty <- getType =<< field 0 numeric -- pointer type@@ -502,37 +612,37 @@ ity = if explicitType then PtrTo instty else instty ret <- if explicitType- then return instty- else elimPtrTo instty- `mplus` fail "invalid return type in INST_ALLOCA"+ then return instty+ else Assert.elimPtrTo "In return type:" instty result ity (Alloca ret sval (Just aval)) d -- [opty,op,align,vol] 20 -> label "FUNC_CODE_INST_LOAD" $ do (tv,ix) <- getValueTypePair t r 0+ Assert.recordSizeIn r [ix + 2, ix + 3] (ret,ix') <- if length (recordFields r) == ix + 3 then do ty <- getType =<< parseField r ix numeric return (ty,ix+1) - else do ty <- elimPtrTo (typedType tv)- `mplus` fail "invalid type to INST_LOAD"+ else do ty <- Assert.elimPtrTo "" (typedType tv) return (ty,ix) aval <- parseField r ix' numeric let align | aval > 0 = Just (bit aval `shiftR` 1) | otherwise = Nothing- result ret (Load (tv { typedType = PtrTo ret }) align) d+ result ret (Load ret tv Nothing align) d -- 21 is unused -- 22 is unused 23 -> label "FUNC_CODE_INST_VAARG" $ do+ Assert.recordSizeGreater r 2 let field = parseField r ty <- getType =<< field 0 numeric- op <- getValue ty =<< field 1 numeric+ op <- getValue t ty =<< field 1 numeric resTy <- getType =<< field 2 numeric result resTy (VaArg op resTy) d @@ -540,25 +650,37 @@ 24 -> label "FUNC_CODE_INST_STORE_OLD" $ do let field = parseField r (ptr,ix) <- getValueTypePair t r 0- ty <- elimPtrTo (typedType ptr)- `mplus` fail "invalid type to INST_STORE"- val <- getValue ty =<< field ix numeric+ ty <- Assert.elimPtrTo "" (typedType ptr)+ val <- getValue t ty =<< field ix numeric aval <- field (ix+1) numeric let align | aval > 0 = Just (bit aval `shiftR` 1) | otherwise = Nothing- effect (Store val ptr align) d+ effect (Store val ptr Nothing align) d -- 25 is unused - -- [opty, opval, n x indices]+ -- LLVM 6: [opty, opval, n x indices] 26 -> label "FUNC_CODE_INST_EXTRACTVAL" $ do- (tv,ix) <- getValueTypePair t r 0- ixs <- parseIndexes r ix- ret <- interpValueIndex (typedType tv) ixs- result ret (ExtractValue tv ixs) d+ (tv, ix) <- getValueTypePair t r 0 + when (length (recordFields r) == ix) $+ fail "`extractval` instruction had zero indices"++ ixs <- parseIndexes r ix+ let instr = ExtractValue tv ixs++ -- The return type of this instruction depends on the given indices into the+ -- type.+ ret <- interpValueIndex (typedType tv) ixs+ result ret instr d+ 27 -> label "FUNC_CODE_INST_INSERTVAL" $ do (tv,ix) <- getValueTypePair t r 0++ -- See comment in FUNC_CODE_INST_EXTRACTVAL+ when (length (recordFields r) == ix) $+ fail "Invalid instruction with zero indices"+ (elt,ix') <- getValueTypePair t r ix ixs <- parseIndexes r ix' result (typedType tv) (InsertValue tv elt ixs) d@@ -568,8 +690,9 @@ 29 -> label "FUNC_CODE_INST_VSELECT" $ do let field = parseField r (tv,ix) <- getValueTypePair t r 0- fv <- getValue (typedType tv) =<< field ix numeric+ fv <- getValue t (typedType tv) =<< field ix numeric (c,_) <- getValueTypePair t r (ix+1)+ -- XXX: we're ignoring the fast-math flags result (typedType tv) (Select c tv (typedValue fv)) d 30 -> label "FUNC_CODE_INST_INBOUNDS_GEP_OLD" (parseGEP t (Just True) r d)@@ -577,7 +700,7 @@ 31 -> label "FUNC_CODE_INST_INDIRECTBR" $ do let field = parseField r ty <- getType =<< field 0 numeric- addr <- getValue ty =<< field 1 numeric+ addr <- getValue t ty =<< field 1 numeric ls <- parseIndexes r 2 effect (IndirectBr addr ls) d @@ -587,29 +710,26 @@ loc <- getLastLoc updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d - -- [paramattrs, cc, fnty, fnid, arg0 .. arg n]+ -- [paramattrs, cc, mb fmf, mb fnty, fnid, arg0 .. arg n, varargs] 34 -> label "FUNC_CODE_INST_CALL" $ do+ Assert.recordSizeGreater r 2 let field = parseField r - -- pal <- field 0 numeric+ -- pal <- field 0 numeric -- N.B. skipping param attributes ccinfo <- field 1 numeric-- (mbFnTy, ix) <- if testBit (ccinfo :: Word32) 15- then do fnTy <- getType =<< field 2 numeric- return (Just fnTy, 3)- else return (Nothing, 2)+ let ix0 = if testBit ccinfo 17 then 3 else 2 -- N.B. skipping fast-math flags+ (mbFnTy, ix1) <- if testBit (ccinfo :: Word32) callExplicitTypeBit+ then do fnTy <- getType =<< field ix0 numeric+ return (Just fnTy, ix0+1)+ else return (Nothing, ix0) - (Typed opTy fn, ix') <- getValueTypePair t r ix+ (Typed opTy fn, ix2) <- getValueTypePair t r ix1 `mplus` fail "Invalid record" - op <- elimPtrTo opTy `mplus` fail "Callee is not a pointer type"- fnty <- case mbFnTy of- Just ty | ty == op -> return op- | otherwise -> fail "Explicit call type does not match \- \pointee type of callee operand"-- Nothing ->+ Just ty -> return ty+ Nothing -> do+ op <- Assert.elimPtrTo "Callee is not a pointer type" opTy case op of FunTy{} -> return op _ -> fail "Callee is not of pointer to function type"@@ -617,11 +737,15 @@ label (show fn) $ do (ret,as,va) <- elimFunTy fnty `mplus` fail "invalid CALL record"- args <- parseCallArgs t va r ix' as- result ret (Call False opTy fn args) d+ args <- parseCallArgs t va r ix2 as+ -- Use `fnty` instead of `opTy` as the function type, as `opTy` will be+ -- a pointer type. See Note [Typing function applications].+ result ret (Call False fnty fn args) d -- [Line,Col,ScopeVal, IAVal] 35 -> label "FUNC_CODE_DEBUG_LOC" $ do+ Assert.recordSizeGreater r 3+ let field = parseField r line <- field 0 numeric col <- field 1 numeric@@ -641,25 +765,30 @@ , dlCol = col , dlScope = typedValue scope , dlIA = typedValue `fmap` ia+ , dlImplicit = False } setLastLoc loc updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d -- [ordering, synchscope] 36 -> label "FUNC_CODE_INST_FENCE" $ do- notImplemented+ Assert.recordSizeIn r [2]+ mordval <- getDecodedOrdering =<< parseField r 0 unsigned+ -- TODO: parse scope+ case mordval of+ Just ordval -> effect (Fence Nothing ordval) d+ Nothing -> fail "`fence` instruction requires ordering" -- [ptrty,ptr,cmp,new, align, vol, -- ordering, synchscope]- 37 -> label "FUNC_CODE_INST_CMPXCHG" $ do+ 37 -> label "FUNC_CODE_INST_CMPXCHG_OLD" $ do notImplemented - -- [ptrty,ptr,val, operation,- -- align, vol,- -- ordering,synchscope]- 38 -> label "FUNC_CODE_INST_ATOMICRMW" $ do- notImplemented+ -- LLVM 6.0: [ptrty, ptr, val, operation, vol, ordering, ssid]+ 38 -> label "FUNC_CODE_INST_ATOMICRMW_OLD" $+ parseAtomicRMW True t r d + -- [opval] 39 -> label "FUNC_CODE_RESUME" $ do (tv,_) <- getValueTypePair t r 0@@ -667,6 +796,7 @@ -- [ty,val,val,num,id0,val0...] 40 -> label "FUNC_CODE_LANDINGPAD_OLD" $ do+ Assert.recordSizeGreater r 3 let field = parseField r ty <- getType =<< field 0 numeric (persFn,ix) <- getValueTypePair t r 1@@ -674,13 +804,36 @@ let isCleanup = val /= (0 :: Int) len <- field (ix + 1) numeric clauses <- parseClauses t r len (ix + 2)- result ty (LandingPad ty persFn isCleanup clauses) d+ result ty (LandingPad ty (Just persFn) isCleanup clauses) d - -- [opty, op, align, vol,- -- ordering, synchscope]+ -- [opty, op, align, vol, ordering, synchscope] 41 -> label "FUNC_CODE_LOADATOMIC" $ do- notImplemented+ (tv,ix) <- getValueTypePair t r 0 + Assert.recordSizeIn r [ix + 4, ix+ 5]++ (ret,ix') <-+ if length (recordFields r) == ix + 5+ then do ty <- getType =<< parseField r ix numeric+ return (ty, ix + 1)++ else do ty <- Assert.elimPtrTo "" (typedType tv)+ return (ty, ix)++ ordval <- getDecodedOrdering =<< parseField r (ix' + 2) unsigned+ when (ordval `elem` Nothing:map Just [Release, AcqRel]) $+ fail $ "Invalid atomic ordering: " ++ show ordval++ aval <- parseField r ix' numeric+ let align | aval > 0 = Just (bit aval `shiftR` 1)+ | otherwise = Nothing++ when (ordval /= Nothing && align == Nothing)+ (fail "Invalid record")++ result ret (Load ret tv ordval align) d++ -- [ptrty, ptr, val, align, vol, ordering, synchscope] 42 -> label "FUNC_CODE_INST_STOREATOMIC_OLD" $ do notImplemented@@ -691,33 +844,122 @@ let field = parseField r (ptr,ix) <- getValueTypePair t r 0 (val,ix') <- getValueTypePair t r ix++ Assert.recordSizeIn r [ix' + 2]+ aval <- field ix' numeric let align | aval > 0 = Just (bit aval `shiftR` 1) | otherwise = Nothing- effect (Store val ptr align) d+ effect (Store val ptr Nothing align) d + -- LLVM 6: [ptrty, ptr, val, align, vol, ordering, ssid] 45 -> label "FUNC_CODE_INST_STOREATOMIC" $ do- notImplemented+ (ptr, ix) <- getValueTypePair t r 0+ (val, ix') <- getValueTypePair t r ix - 46 -> label "FUNC_CODE_CMPXCHG" $ do- notImplemented+ Assert.recordSizeIn r [ix' + 4] + -- TODO: There's no spot in the AST for this ordering. Should there be?+ ordering <- getDecodedOrdering =<< parseField r (ix' + 2) unsigned+ when (ordering `elem` Nothing:map Just [Acquire, AcqRel]) $+ fail $ "Invalid atomic ordering: " ++ show ordering++ -- TODO: parse sync scope (ssid)++ -- copy-pasted from LOADATOMIC+ aval <- parseField r ix' numeric+ let align | aval > 0 = Just (bit aval `shiftR` 1)+ | otherwise = Nothing++ effect (Store val ptr ordering align) d++ -- LLVM 6: [ptrty, ptr, cmp, new, vol, successordering, ssid,+ -- failureordering?, isweak?]+ 46 -> label "FUNC_CODE_INST_CMPXCHG" $ do+ (ptr, ix) <- getValueTypePair t r 0+ (val, ix') <- getValueTypePair t r ix+ new <- getValue t (typedType val) =<< parseField r ix' numeric+ let ix'' = ix' + 1 -- TODO: is this right?++ -- TODO: record size assertion+ -- Assert.recordSizeGreater r (ix'' + 5)++ unless (typedType val `eqTypeModuloOpaquePtrs` typedType new)+ -- This test is generally validating the behavior of this library: the LLVM+ -- bitcode was likely generated by LLVM and is therefore "correct".+ $ fail $ unlines $+ [ "Mismatched value types:"+ , "cmp value: " ++ show (typedValue val)+ , "new value: " ++ show (typedValue new)+ , "cmp type: " ++ show (typedType val)+ , "new type: " ++ show (typedType new)+ ]++ volatile <- parseField r ix'' boolean++ successOrdering_ <- getDecodedOrdering =<< parseField r (ix'' + 1) unsigned+ let successOrderMsg ord = "Invalid success ordering: " ++ show ord+ successOrdering <-+ case successOrdering_ of+ Nothing -> fail (successOrderMsg successOrdering_)+ Just Unordered -> fail (successOrderMsg successOrdering_)+ Just ordering -> pure ordering++ -- TODO: parse sync scope (ssid)+ -- ssid <- parseField r (ix'' + 2) ssid++ let len = length (recordFields r)+ failureOrdering_ <-+ if len < 7+ -- Implementation of getStrongestFailureOrdering in llvm/IR/Instructions.h:+ then case successOrdering of+ Release -> pure (Just Monotonic)+ Monotonic -> pure (Just Monotonic)+ Acquire -> pure (Just Acquire) -- TODO: AcquireRelease?+ SeqCst -> pure (Just SeqCst)+ _ -> fail (successOrderMsg successOrdering)+ else getDecodedOrdering =<< parseField r (ix'' + 3) unsigned+ failureOrdering <-+ case failureOrdering_ of+ Nothing -> fail "Invalid failure ordering (Nothing)"+ Just ord -> pure ord++ weak <-+ if len < 8+ then fail "Not yet implemented: old-style cmpxchg instruction (weak)"+ else parseField r (ix'' + 4) boolean++ -- The return type of cmpxchg is: the value that was present in the memory+ -- location and a boolean indicating whether it was overwritten.+ let ty = Struct [typedType val, PrimType (Integer 1)]+ result ty (CmpXchg weak volatile ptr val new Nothing successOrdering failureOrdering) d+ 47 -> label "FUNC_CODE_LANDINGPAD" $ do- notImplemented+ Assert.recordSizeGreater r 2+ let field = parseField r+ ty <- getType =<< field 0 numeric+ isCleanup <- (/=(0::Int)) <$> field 1 numeric+ len <- field 2 numeric+ clauses <- parseClauses t r len 3+ result ty (LandingPad ty Nothing isCleanup clauses) d 48 -> label "FUNC_CODE_CLEANUPRET" $ do+ -- Assert.recordSizeIn r [1, 2] notImplemented 49 -> label "FUNC_CODE_CATCHRET" $ do+ -- Assert.recordSizeIn r [2] notImplemented 50 -> label "FUNC_CODE_CATCHPAD" $ do notImplemented 51 -> label "FUNC_CODE_CLEANUPPAD" $ do+ -- Assert.recordSizeGreater r [1] notImplemented 52 -> label "FUNC_CODE_CATCHSWITCH" $ do+ -- Assert.recordSizeGreater r [1] notImplemented -- 53 is unused@@ -726,13 +968,71 @@ 55 -> label "FUNC_CODE_OPERAND_BUNDLE" $ do notImplemented + -- [opval,ty,opcode]+ 56 -> label "FUNC_CODE_INST_UNOP" $ do+ let field = parseField r+ (v,ix) <- getValueTypePair t r 0+ mkInstr <- field ix unop+ -- XXX: we're ignoring the fast-math flags+ result (typedType v) (mkInstr v) d++ -- LLVM 9: [attr, cc, norm, transfs, fnty, fnid, args...]+ 57 -> label "FUNC_CODE_INST_CALLBR" $ do+ -- This implementation shares a lot with the parser for `call`, but they+ -- have different fields and so different handling of indices. In+ -- particular, the handling of basic block destinations is unique to+ -- `callbr`, and `callbr` doesn't support fast math flags.++ let field = parseField r+ -- pal <- field 0 numeric -- N.B. skipping param attributes+ ccinfo <- field 1 unsigned+ normal <- field 2 numeric+ numIndirect <- field 3 numeric+ indirectDests <- mapM (\idx -> field (4 + idx) numeric) [0..numIndirect - 1]+ let ix0 = 4 + numIndirect+ (mbFnTy, ix1) <- if testBit (ccinfo :: Word32) callExplicitTypeBit+ then do fnTy <- getType =<< field ix0 numeric+ return (Just fnTy, ix0+1)+ else return (Nothing, ix0)++ (Typed opTy fn, ix2) <- getValueTypePair t r ix1+ `mplus` fail "Invalid callbr record"++ fnty <- case mbFnTy of+ Just ty -> return ty+ Nothing -> do+ op <- Assert.elimPtrTo "callbr callee is not a pointer type" opTy+ case op of+ FunTy{} -> return op+ _ -> fail "Callee is not of pointer to function type"++ label (show fn) $ do+ (ret,as,va) <- elimFunTy fnty `mplus` fail "invalid CALLBR record"+ args <- parseCallArgs t va r ix2 as+ -- Use `fnty` instead of `opTy` as the function type, as `opTy` will be+ -- a pointer type. See Note [Typing function applications].+ result ret (CallBr fnty fn args normal indirectDests) d++ -- [opty, opval]+ 58 -> label "FUNC_CODE_INST_FREEZE" $ do+ (v,_) <- getValueTypePair t r 0+ result (typedType v) (Freeze v) d++ -- LLVM 13: [ptrty, ptr, valty, val, operation, vol, ordering, ssid]+ 59 -> label "FUNC_CODE_INST_ATOMICRMW" $+ parseAtomicRMW False t r d++ -- [opty,opval,opval,pred] code | code == 9 || code == 28 -> label "FUNC_CODE_INST_CMP2" $ do let field = parseField r (lhs,ix) <- getValueTypePair t r 0- rhs <- getValue (typedType lhs) =<< field ix numeric+ `mplus` (do i <- adjustId =<< field 0 numeric+ cxt <- getContext+ return (forwardRef cxt i t, 1))+ rhs <- getValue t (typedType lhs) =<< field ix numeric let ty = typedType lhs parseOp | isPrimTypeOf isFloatingPoint ty ||@@ -742,7 +1042,8 @@ | otherwise = return . ICmp <=< icmpOp - op <- field (ix+1) parseOp+ op <- field (ix + 1) parseOp+ -- XXX: we're ignoring the fast-math flags let boolTy = Integer 1 let rty = case ty of@@ -759,9 +1060,9 @@ parseFunctionBlockEntry globals t d (metadataBlockId -> Just es) = do (_, (globalUnnamedMds, localUnnamedMds), _, _, _) <- parseMetadataBlock globals t es- unless (null localUnnamedMds)- (fail "parseFunctionBlockEntry PANIC: unexpected local unnamed metadata")- return d { partialGlobalMd = globalUnnamedMds ++ partialGlobalMd d }+ 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 (_,(globalUnnamedMds, localUnnamedMds),instrAtt,fnAtt,_)@@ -802,30 +1103,25 @@ b' | null use = b | otherwise = b { partialStmts = foldl addMd (partialStmts b) use } - addMd stmts (i,md') = Seq.adjust update i stmts+ addMd stmts (i,md') = Seq.adjust update (i-off) stmts where update (Result n s md) = Result n s (md ++ md') update (Effect s md) = Effect s (md ++ md') go _ _ Seq.EmptyL = Seq.empty -baseType :: Type -> Type-baseType (PtrTo ty) = ty-baseType (Array _ ty) = ty-baseType (Vector _ ty) = ty-baseType ty = ty- -- [n x operands] parseGEP :: ValueTable -> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine parseGEP t mbInBound r d = do- (ib, tv, r', ix) <-+ (ib, ty, tv, r', ix) <- case mbInBound of -- FUNC_CODE_INST_GEP_OLD -- FUNC_CODE_INST_INBOUNDS_GEP_OLD Just ib -> do (tv,ix') <- getValueTypePair t r 0- return (ib, tv, r, ix')+ ty <- Assert.elimPtrTo "GEP not headed by pointer" (typedType tv)+ return (ib, ty, tv, r, ix') -- FUNC_CODE_INST_GEP Nothing -> do@@ -834,21 +1130,67 @@ ib <- field 0 boolean ty <- getType =<< field 1 numeric (tv,ix') <- getValueTypePair t r' 2- -- TODO: the following sometimes fails, but it doesn't seem to matter.- {-- unless (baseType (typedType tv) == ty)- (fail $ unlines [ "Explicit gep type does not match base type of pointer operand"- , "Declared type: " ++ show (ppType ty)- , "Operand type: " ++ show (ppType (typedType tv))- , "Base type of operand: " ++ show (ppType (baseType (typedType tv)))- ])- -}- return (ib, tv { typedType = PtrTo ty }, r', ix')+ return (ib, ty, tv, r', ix') args <- label "parseGepArgs" (parseGepArgs t r' ix)- rty <- label "interpGep" (interpGep (typedType tv) args)- result rty (GEP ib tv args) d+ rty <- label "interpGep" (interpGep ty tv args)+ result rty (GEP ib ty tv args) d +-- Parse an @atomicrmw@ instruction, which can be represented by one of the+-- following function codes:+--+-- * FUNC_CODE_INST_ATOMICRMW_OLD, which was introduced in LLVM 6.0.+-- [ptrty, ptr, val, operation, vol, ordering, ssid]+--+-- * FUNC_CODE_INST_ATOMICRMW, which was introduced in LLVM 13.+-- [ptrty, ptr, valty, val, operation, vol, ordering, ssid]+--+-- The only difference between the two is that FUNC_CODE_INST_ATOMICRMW has a+-- @valty@ field, whereas FUNC_CODE_INST_ATOMICRMW_OLD does not (it reuses the+-- type that @ptrty@ points to as the @valty@).+--+-- The parsing code was inspired by the upstream code at+-- https://github.com/llvm/llvm-project/blob/2362c4ecdc88123e5d54c7ebe30889fbfa760a88/llvm/lib/Bitcode/Reader/BitcodeReader.cpp#L5658-L5720.+parseAtomicRMW :: Bool -> ValueTable -> Record -> PartialDefine -> Parse PartialDefine+parseAtomicRMW old t r d = do+ -- TODO: parse sync scope (ssid)+ (ptr, ix0) <- getValueTypePair t r 0++ (val, ix1) <-+ if old+ then -- FUNC_CODE_INST_ATOMICRMW_OLD+ do ty <- Assert.elimPtrTo "atomicrmw instruction not headed by pointer" (typedType ptr)+ typed <- getValue t ty =<< parseField r ix0 numeric+ if ty /= (typedType typed)+ then fail $ unlines $ [ "Wrong type of value retrieved from value table"+ , "Expected: " ++ show (ty)+ , "Got: " ++ show (typedType typed)+ ]+ else pure (typed, ix0 + 1)+ else -- FUNC_CODE_INST_ATOMICRMW+ getValueTypePair t r ix0++ -- Catch incorrect operand types+ let valTy = typedType val+ unless (case valTy of+ PrimType (Integer _) -> True+ PrimType (FloatType _) -> True+ _ -> False) $+ fail $ "Expected integer or float operand, found " ++ show valTy++ -- TODO: enable this assertion. Is getTypeValuePair returning the wrong value?+ -- when (length (recordFields r) /= ix1 + 4) $ do+ -- fail $ "Invalid record size: " ++ show (length (recordFields r))++ operation <- getDecodedAtomicRWOp =<< parseField r ix1 numeric+ volatile <- parseField r (ix1 + 1) nonzero+ ordering <- parseField r (ix1 + 2) unsigned >>= getDecodedOrdering >>=+ \case+ Just ordering -> pure ordering+ Nothing -> fail $ "`atomicrmw` requires ordering: ix == " ++ show ix1++ result (typedType val) (AtomicRW volatile operation ptr val Nothing ordering) d+ -- | Generate a statement that doesn't produce a result. effect :: Instr' Int -> PartialDefine -> Parse PartialDefine effect i d = addStmt (Effect i []) d@@ -884,22 +1226,23 @@ return (typedValue val,bid) loop n- | n >= len = return []- | otherwise = do- entry <- parse n- rest <- loop (n+2)- return (entry:rest)+ -- We must stop when @n@ is either equal to @len@, or to @len - 1@ in the+ -- presence of fast math flags.+ | len - n < 2 = return []+ | otherwise = (:) <$> parse n <*> loop (n + 2) -- | Parse the arguments for a call record. parseCallArgs :: ValueTable -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]-parseCallArgs t = parseArgs t $ \ ty i ->+parseCallArgs t b r = parseArgs t op b r+ where+ op ty i = case ty of PrimType Label -> return (Typed ty (ValLabel i))- _ -> getValue ty i+ _ -> getValue t ty i -- | Parse the arguments for an invoke record. parseInvokeArgs :: ValueTable -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]-parseInvokeArgs t = parseArgs t getValue+parseInvokeArgs t = parseArgs t (getValue t) -- | Parse arguments for the invoke and call instructions. parseArgs :: ValueTable -> (Type -> Int -> Parse (Typed PValue))@@ -936,19 +1279,22 @@ rest <- loop ix' return (tv:rest) --- | Interpret the getelementptr arguments, to determine the final type of the--- instruction.-interpGep :: Type -> [Typed PValue] -> Parse Type-interpGep ty vs = check (resolveGep ty vs)+-- | Interpret a getelementptr instruction to determine its result type.+interpGep :: Type -> Typed PValue -> [Typed PValue] -> Parse Type+interpGep baseTy ptr vs = check (resolveGep baseTy ptr vs) where check res = case res of HasType rty -> return (PtrTo rty)- Invalid -> fail "unable to determine the type of getelementptr"+ Invalid -> fail $ unlines $+ [ "Unable to determine the type of getelementptr"+ , "Base type: " ++ show baseTy+ , "Pointer value: " ++ show ptr+ ] Resolve i k -> do ty' <- getType' =<< getTypeId i check (k ty') -parseIndexes :: Num a => Record -> Int -> Parse [a]+parseIndexes :: (Num a, Bits a) => Record -> Int -> Parse [a] parseIndexes r = loop where field = parseField r@@ -957,11 +1303,19 @@ rest <- loop (n+1) `mplus` return [] return (ix:rest) -interpValueIndex :: Type -> [Int32] -> Parse Type+interpValueIndex :: Type -- ^ Aggregate (struct/array) type to index into+ -> [Int32] -- ^ Indices+ -> Parse Type interpValueIndex ty is = check (resolveValueIndex ty is) where check res = case res of- Invalid -> fail "unable to determine the type of (extract/insert)value"+ Invalid ->+ fail $ unlines $+ [ "Unable to determine the return type of `extractvalue`"+ , "Hint: The input type should be an aggregate type (struct or array)"+ , "Input type: " ++ show ty+ , "Indices: " ++ show is+ ] HasType rty -> return rty Resolve i k -> do ty' <- getType' =<< getTypeId i@@ -997,7 +1351,7 @@ -- | See the comment for 'parseSwitchLabels' for information about what this -- does.-parseNewSwitchLabels :: Int32 -> Record -> Int -> Int -> Parse [(Integer,Int)]+parseNewSwitchLabels :: Word32 -> Record -> Int -> Int -> Parse [(Integer,Int)] parseNewSwitchLabels width r = loop where field = parseField r@@ -1063,3 +1417,63 @@ 0 -> return (Catch val : cs) 1 -> return (Filter val : cs) _ -> fail ("Invalid clause type: " ++ show cty)+++-- | 'Nothing' corresponds to @NotAtomic@ in the LLVM source+getDecodedOrdering :: Word32 -> Parse (Maybe AtomicOrdering)+getDecodedOrdering 0 = return Nothing+getDecodedOrdering 1 = return (Just Unordered)+getDecodedOrdering 2 = return (Just Monotonic)+getDecodedOrdering 3 = return (Just Acquire)+getDecodedOrdering 4 = return (Just Release)+getDecodedOrdering 5 = return (Just AcqRel)+getDecodedOrdering 6 = return (Just SeqCst)+getDecodedOrdering i = Assert.unknownEntity "atomic ordering" i+++-- https://github.com/llvm-mirror/llvm/blob/release_60/include/llvm/Bitcode/LLVMBitCodes.h#L377+getDecodedAtomicRWOp :: Integer -> Parse AtomicRWOp+getDecodedAtomicRWOp 0 = pure AtomicXchg+getDecodedAtomicRWOp 1 = pure AtomicAdd+getDecodedAtomicRWOp 2 = pure AtomicSub+getDecodedAtomicRWOp 3 = pure AtomicAnd+getDecodedAtomicRWOp 4 = pure AtomicNand+getDecodedAtomicRWOp 5 = pure AtomicOr+getDecodedAtomicRWOp 6 = pure AtomicXor+getDecodedAtomicRWOp 7 = pure AtomicMax+getDecodedAtomicRWOp 8 = pure AtomicMin+getDecodedAtomicRWOp 9 = pure AtomicUMax+getDecodedAtomicRWOp 10 = pure AtomicUMin+getDecodedAtomicRWOp v = Assert.unknownEntity "atomic RWOp" v++{-+Note [Typing function applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The LLVM Language Reference Manual says the following about the `call`+instruction:++ <result> = [tail | musttail | notail ] call [fast-math flags] [cconv] [ret attrs] [addrspace(<num>)]+ <ty>|<fnty> <fnptrval>(<function args>) [fn attrs] [ operand bundles ]++ ...++ * ‘fnty’: shall be the signature of the function being called. [...]+ * ‘fnptrval’: An LLVM value containing a pointer to a function to be called. [...]++One slightly surprising aspect of this instruction (at least, this was not+obvious to me when I first read it) is that `fnptrval` does _not_ have the type+`fnty`. Rather, `fnptrval` has a pointer type, and the underlying memory being+pointed to is treated as having type `fnty`.++A consequence of this property is that `fnty` is /never/ a pointer type. It is+easy to accidentally give the `fnty` of a `call` instruction a pointer type if+you simply compute the type of `fnptrval`, but this is incorrect. This is+especially incorrect in a world where pointers are opaque (see+https://llvm.org/docs/OpaquePointers.html), as you cannot know know what a+pointer's pointee type is by looking at the type alone. Instead, you must look+at the surrounding instruction to know what the pointee type is. In the case of+the `call` instruction, the pointee type for `fnptrval` is precisely `fnty`.++Similar reasoning applies to the `callbr` and `invoke` instructions, which also+invoke a pointer whose underlying memory has a function type.+-}
src/Data/LLVM/BitCode/IR/Globals.hs view
@@ -35,7 +35,8 @@ -- ] parseGlobalVar :: Int -> Record -> Parse PartialGlobal parseGlobalVar n r = label "GLOBALVAR" $ do- let field = parseField r+ (name, offset) <- oldOrStrtabName n r+ let field i = parseField r (i + offset) ptrty <- getType =<< field 0 numeric mask <- field 1 numeric let isconst = testBit (mask :: Word32) 0@@ -43,27 +44,28 @@ initid <- field 2 numeric link <- field 3 linkage - mbAlign <- if length (recordFields r) > 4+ mbAlign <- if length (recordFields r) > (4 + offset) then Just `fmap` field 4 numeric else return Nothing+ vis <- if length (recordFields r) > (6 + offset) && not (link `elem` [Internal, Private])+ then field 6 visibility+ else pure DefaultVisibility ty <- if explicitTy then return ptrty- else elimPtrTo ptrty `mplus` fail "Invalid type for value"+ else elimPtrTo ptrty `mplus` (fail $ "Invalid type for value: " ++ show ptrty) - name <- entryName n- _ <- pushValue (Typed (PtrTo ty) (ValSymbol (Symbol name)))+ _ <- pushValue (Typed (PtrTo ty) (ValSymbol name)) let valid | initid == 0 = Nothing | otherwise = Just (initid - 1) attrs = GlobalAttrs- { gaLinkage = do- guard (link /= External)- return link+ { gaLinkage = Just link+ , gaVisibility = Just vis , gaConstant = isconst } return PartialGlobal- { pgSym = Symbol name+ { pgSym = name , pgAttrs = attrs , pgType = ty , pgValueIx = valid@@ -77,11 +79,11 @@ finalizeGlobal :: PartialGlobal -> Parse Global finalizeGlobal pg = case pgValueIx pg of- Nothing -> mkGlobal Nothing+ Nothing -> liftFinalize $ mkGlobal Nothing Just ix -> do tv <- getFnValueById (pgType pg) (fromIntegral ix)- val <- relabel (const requireBbEntryName) (typedValue tv)- mkGlobal (Just val)+ val <- liftFinalize $ relabel (const requireBbEntryName) (typedValue tv)+ liftFinalize $ mkGlobal (Just val) where mkGlobal mval = do md <- mapM (relabel (const requireBbEntryName)) (pgMd pg)
src/Data/LLVM/BitCode/IR/Metadata.hs view
@@ -1,859 +1,1294 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RecursiveDo #-}--module Data.LLVM.BitCode.IR.Metadata (- parseMetadataBlock- , parseMetadataKindEntry- , PartialUnnamedMd(..)- , finalizePartialUnnamedMd- , finalizePValMd- , InstrMdAttachments- , PFnMdAttachments- , PKindMd- , PGlobalAttachments- ) where--import Data.LLVM.BitCode.Bitstream-import Data.LLVM.BitCode.Match-import Data.LLVM.BitCode.Parse-import Data.LLVM.BitCode.Record-import Text.LLVM.AST-import Text.LLVM.Labels--import Control.Exception (throw)-import Control.Monad (foldM,guard,mplus,unless,when)-import Data.List (mapAccumL)-import Data.Maybe (fromMaybe)-import Data.Bits (shiftR, testBit, shiftL)-import Data.Word (Word32,Word64)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as Char8 (unpack)-import qualified Data.Map as Map----- Parsing State -----------------------------------------------------------------data MetadataTable = MetadataTable- { mtEntries :: MdTable- , mtNextNode :: !Int- , mtNodes :: Map.Map Int (Bool,Bool,Int)- -- ^ 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 -} ->- MdTable -> MetadataTable-emptyMetadataTable globals es = MetadataTable- { mtEntries = es- , mtNextNode = globals- , mtNodes = Map.empty- }--metadata :: PValMd -> Typed PValue-metadata = Typed (PrimType Metadata) . ValMd--addMetadata :: PValMd -> MetadataTable -> (Int,MetadataTable)-addMetadata val mt = (ix, mt { mtEntries = es' })- where- (ix,es') = addValue' (metadata val) (mtEntries mt)--addMdValue :: Typed PValue -> MetadataTable -> MetadataTable-addMdValue tv mt = mt { mtEntries = addValue tv' (mtEntries mt) }- where- -- explicitly make a metadata value out of a normal value- tv' = Typed { typedType = PrimType Metadata- , typedValue = ValMd (ValMdValue tv)- }--nameNode :: Bool -> Bool -> Int -> MetadataTable -> MetadataTable-nameNode fnLocal isDistinct ix mt = mt- { mtNodes = Map.insert ix (fnLocal,isDistinct,mtNextNode mt) (mtNodes mt)- , mtNextNode = mtNextNode mt + 1- }--addString :: String -> MetadataTable -> MetadataTable-addString str = snd . addMetadata (ValMdString str)--addStrings :: [String] -> MetadataTable -> MetadataTable-addStrings strs mt = foldl (flip addString) mt strs--addLoc :: Bool -> PDebugLoc -> MetadataTable -> MetadataTable-addLoc isDistinct loc mt = nameNode False isDistinct ix mt'- where- (ix,mt') = addMetadata (ValMdLoc loc) mt--addDebugInfo- :: Bool- -> DebugInfo' Int- -> MetadataTable- -> MetadataTable-addDebugInfo isDistinct di mt = nameNode False isDistinct ix mt'- where- (ix,mt') = addMetadata (ValMdDebugInfo di) mt---- | Add a new node, that might be distinct.-addNode :: Bool -> [Maybe PValMd] -> MetadataTable -> MetadataTable-addNode isDistinct vals mt = nameNode False isDistinct ix mt'- where- (ix,mt') = addMetadata (ValMdNode vals) mt--addOldNode :: Bool -> [Typed PValue] -> MetadataTable -> MetadataTable-addOldNode fnLocal vals mt = nameNode fnLocal False ix mt'- where- (ix,mt') = addMetadata (ValMdNode [ Just (ValMdValue tv) | tv <- vals ]) mt--mdForwardRef :: [String] -> MetadataTable -> Int -> PValMd-mdForwardRef cxt mt ix = fromMaybe fallback nodeRef- where- fallback = case forwardRef cxt ix (mtEntries mt) of- Typed { typedValue = ValMd md } -> md- tv -> ValMdValue tv- reference (_,_,r) = ValMdRef r- nodeRef = reference `fmap` Map.lookup ix (mtNodes mt)--mdForwardRefOrNull :: [String] -> MetadataTable -> Int -> Maybe PValMd-mdForwardRefOrNull cxt mt ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1))- | otherwise = Nothing--mdNodeRef :: [String] -> MetadataTable -> Int -> Int-mdNodeRef cxt mt ix =- maybe (throw (BadValueRef cxt ix)) prj (Map.lookup ix (mtNodes mt))- where- prj (_,_,x) = x--mdString :: [String] -> MetadataTable -> Int -> String-mdString cxt mt ix =- fromMaybe (throw (BadValueRef cxt ix)) (mdStringOrNull cxt mt ix)--mdStringOrNull :: [String] -> MetadataTable -> Int -> Maybe String-mdStringOrNull cxt mt ix =- case mdForwardRefOrNull cxt mt ix of- Nothing -> Nothing- Just (ValMdString str) -> Just str- Just _ -> throw (BadTypeRef cxt ix)--mkMdRefTable :: MetadataTable -> MdRefTable-mkMdRefTable mt = Map.mapMaybe step (mtNodes mt)- where- step (fnLocal,_,ix) = do- guard (not fnLocal)- return ix--data PartialMetadata = PartialMetadata- { pmEntries :: MetadataTable- , pmNamedEntries :: Map.Map String [Int]- , pmNextName :: Maybe String- , pmInstrAttachments :: InstrMdAttachments- , pmFnAttachments :: PFnMdAttachments- , pmGlobalAttachments:: PGlobalAttachments- } deriving (Show)--emptyPartialMetadata ::- Int {- ^ globals seen so far -} ->- MdTable -> PartialMetadata-emptyPartialMetadata globals es = PartialMetadata- { pmEntries = emptyMetadataTable globals es- , pmNamedEntries = Map.empty- , pmNextName = Nothing- , pmInstrAttachments = Map.empty- , pmFnAttachments = Map.empty- , pmGlobalAttachments= Map.empty- }--updateMetadataTable :: (MetadataTable -> MetadataTable)- -> (PartialMetadata -> PartialMetadata)-updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) }--addGlobalAttachments ::- Symbol {- ^ name of the global to attach to ^ -} ->- (Map.Map KindMd PValMd) {- ^ metadata references to attach ^ -} ->- (PartialMetadata -> PartialMetadata)-addGlobalAttachments sym mds pm =- pm { pmGlobalAttachments = Map.insert sym mds (pmGlobalAttachments pm)- }--setNextName :: String -> PartialMetadata -> PartialMetadata-setNextName name pm = pm { pmNextName = Just name }--addFnAttachment :: PFnMdAttachments -> PartialMetadata -> PartialMetadata-addFnAttachment att pm =- -- left-biased union, since the parser overwrites metadata as it encounters it- pm { pmFnAttachments = Map.union att (pmFnAttachments pm) }--addInstrAttachment :: Int -> [(KindMd,PValMd)]- -> PartialMetadata -> PartialMetadata-addInstrAttachment instr md pm =- pm { pmInstrAttachments = Map.insert instr md (pmInstrAttachments pm) }--nameMetadata :: [Int] -> PartialMetadata -> Parse PartialMetadata-nameMetadata val pm = case pmNextName pm of- Just name -> return $! pm- { pmNextName = Nothing- , pmNamedEntries = Map.insert name val (pmNamedEntries pm)- }- Nothing -> fail "Expected a metadata name"--namedEntries :: PartialMetadata -> [NamedMd]-namedEntries = map (uncurry NamedMd)- . Map.toList- . pmNamedEntries--data PartialUnnamedMd = PartialUnnamedMd- { pumIndex :: Int- , pumValues :: PValMd- , pumDistinct :: Bool- } deriving (Show)--finalizePartialUnnamedMd :: PartialUnnamedMd -> Parse UnnamedMd-finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` finalizePValMd (pumValues pum)- where- mkUnnamedMd v = UnnamedMd- { umIndex = pumIndex pum- , umValues = v- , umDistinct = pumDistinct pum- }--finalizePValMd :: PValMd -> Parse ValMd-finalizePValMd = relabel (const requireBbEntryName)---- | Partition unnamed entries into global and function local unnamed entries.-unnamedEntries :: PartialMetadata -> ([PartialUnnamedMd],[PartialUnnamedMd])-unnamedEntries pm = foldl resolveNode ([],[]) (Map.toList (mtNodes mt))- where- mt = pmEntries pm- es = valueEntries (mtEntries mt)-- resolveNode (gs,fs) (ref,(fnLocal,d,ix)) = case lookupNode ref d ix of- Just pum | fnLocal -> (gs,pum:fs)- | otherwise -> (pum:gs,fs)-- -- TODO: is this silently eating errors with metadata that's not in the- -- value table?- Nothing -> (gs,fs)-- lookupNode ref d ix = do- Typed { typedValue = ValMd v } <- Map.lookup ref es- return PartialUnnamedMd- { pumIndex = ix- , pumValues = v- , pumDistinct = d- }--type InstrMdAttachments = Map.Map Int [(KindMd,PValMd)]--type PKindMd = Int-type PFnMdAttachments = Map.Map PKindMd PValMd-type PGlobalAttachments = Map.Map Symbol (Map.Map KindMd PValMd)--type ParsedMetadata =- ( [NamedMd]- , ([PartialUnnamedMd],[PartialUnnamedMd])- , InstrMdAttachments- , PFnMdAttachments- , PGlobalAttachments- )--parsedMetadata :: PartialMetadata -> ParsedMetadata-parsedMetadata pm =- ( namedEntries pm- , unnamedEntries pm- , pmInstrAttachments pm- , pmFnAttachments pm- , pmGlobalAttachments pm- )---- Metadata Parsing --------------------------------------------------------------parseMetadataBlock ::- Int {- ^ globals seen so far -} ->- ValueTable -> [Entry] -> Parse ParsedMetadata-parseMetadataBlock globals vt es = label "METADATA_BLOCK" $ do- ms <- getMdTable- let pm0 = emptyPartialMetadata globals ms- rec pm <- foldM (parseMetadataEntry vt (pmEntries pm)) pm0 es- let entries = pmEntries pm- setMdTable (mtEntries entries)- setMdRefs (mkMdRefTable entries)- return (parsedMetadata pm)---- | Parse an entry in the metadata block.------ XXX this currently relies on the constant block having been parsed already.--- Though most bitcode examples I've seen are ordered this way, it would be nice--- to not have to rely on it.-parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry- -> Parse PartialMetadata-parseMetadataEntry vt mt pm (fromEntry -> Just r) =- case recordCode r of- -- [values]- 1 -> label "METADATA_STRING" $ do- str <- parseFields r 0 char `mplus` parseField r 0 string- return $! updateMetadataTable (addString str) pm-- -- [type num, value num]- 2 -> label "METADATA_VALUE" $ do- unless (length (recordFields r) == 2)- (fail "Invalid record")-- let field = parseField r- ty <- getType =<< field 0 numeric- when (ty == PrimType Metadata || ty == PrimType Void)- (fail "invalid record")-- cxt <- getContext- ix <- field 1 numeric- let tv = forwardRef cxt ix vt-- return $! updateMetadataTable (addMdValue tv) pm--- -- [n x md num]- 3 -> label "METADATA_NODE" (parseMetadataNode False mt r pm)-- -- [values]- 4 -> label "METADATA_NAME" $ do- name <- parseFields r 0 char `mplus` parseField r 0 cstring- return $! setNextName name pm-- -- [n x md num]- 5 -> label "METADATA_DISTINCT_NODE" (parseMetadataNode True mt r pm)-- -- [n x [id, name]]- 6 -> label "METADATA_KIND" $ do- kind <- parseField r 0 numeric- name <- parseFields r 1 char- addKind kind name- return pm-- -- [distinct, line, col, scope, inlined-at?]- 7 -> label "METADATA_LOCATION" $ do- -- TODO: broken in 3.7+; needs to be a DILocation rather than an- -- MDLocation, but there appears to be no difference in the- -- bitcode. /sigh/- cxt <- getContext- let field = parseField r- isDistinct <- field 0 nonzero- dlLine <- field 1 numeric- dlCol <- field 2 numeric- dlScope <- mdForwardRef cxt mt <$> field 3 numeric- dlIA <- mdForwardRefOrNull cxt mt <$> field 4 numeric- let loc = DebugLoc { .. }- return $! updateMetadataTable (addLoc isDistinct loc) pm--- -- [n x (type num, value num)]- 8 -> label "METADATA_OLD_NODE" (parseMetadataOldNode False vt mt r pm)-- -- [n x (type num, value num)]- 9 -> label "METADATA_OLD_FN_NODE" (parseMetadataOldNode True vt mt r pm)-- -- [n x mdnodes]- 10 -> label "METADATA_NAMED_NODE" $ do- mdIds <- parseFields r 0 numeric- cxt <- getContext- let ids = map (mdNodeRef cxt mt) mdIds- nameMetadata ids pm-- -- [m x [value, [n x [id, mdnode]]]- 11 -> label "METADATA_ATTACHMENT" $ do- let recordSize = length (recordFields r)- when (recordSize == 0)- (fail "Invalid record")- if (recordSize `mod` 2 == 0)- then label "function attachment" $ do- att <- Map.fromList <$> parseAttachment r 0- return $! addFnAttachment att pm- else label "instruction attachment" $ do- inst <- parseField r 0 numeric- patt <- parseAttachment r 1- att <- mapM (\(k,md) -> (,md) <$> getKind k) patt- return $! addInstrAttachment inst att pm-- 12 -> label "METADATA_GENERIC_DEBUG" $ do- --isDistinct <- parseField r 0 numeric- --tag <- parseField r 1 numeric- --version <- parseField r 2 numeric- --header <- parseField r 3 string- -- TODO: parse all remaining fields- fail "not yet implemented"-- 13 -> label "METADATA_SUBRANGE" $ do- isDistinct <- parseField r 0 nonzero- disrCount <- parseField r 1 numeric- disrLowerBound <- parseField r 2 signedInt64- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoSubrange DISubrange{..})) pm-- -- [distinct, value, name]- 14 -> label "METADATA_ENUMERATOR" $ do- ctx <- getContext- isDistinct <- parseField r 0 nonzero- value <- parseField r 1 signedInt64- name <- mdString ctx mt <$> parseField r 2 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoEnumerator name value)) pm-- 15 -> label "METADATA_BASIC_TYPE" $ do- ctx <- getContext- isDistinct <- parseField r 0 nonzero- dibtTag <- parseField r 1 numeric- dibtName <- mdString ctx mt <$> parseField r 2 numeric- dibtSize <- parseField r 3 numeric- dibtAlign <- parseField r 4 numeric- dibtEncoding <- parseField r 5 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoBasicType DIBasicType{..})) pm-- -- [distinct, filename, directory]- 16 -> label "METADATA_FILE" $ do- ctx <- getContext- isDistinct <- parseField r 0 nonzero- difFilename <- mdString ctx mt <$> parseField r 1 numeric- difDirectory <- mdString ctx mt <$> parseField r 2 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoFile DIFile{..})) pm-- 17 -> label "METADATA_DERIVED_TYPE" $ do- ctx <- getContext- isDistinct <- parseField r 0 nonzero- didtTag <- parseField r 1 numeric- didtName <- mdStringOrNull ctx mt <$> parseField r 2 numeric- didtFile <- mdForwardRefOrNull ctx mt <$> parseField r 3 numeric- didtLine <- parseField r 4 numeric- didtScope <- mdForwardRefOrNull ctx mt <$> parseField r 5 numeric- didtBaseType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric- didtSize <- parseField r 7 numeric- didtAlign <- parseField r 8 numeric- didtOffset <- parseField r 9 numeric- didtFlags <- parseField r 10 numeric- didtExtraData <- mdForwardRefOrNull ctx mt <$> parseField r 11 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoDerivedType DIDerivedType{..})) pm-- 18 -> label "METADATA_COMPOSITE_TYPE" $ do- ctx <- getContext- isDistinct <- parseField r 0 nonzero- dictTag <- parseField r 1 numeric- dictName <- mdStringOrNull ctx mt <$> parseField r 2 numeric- dictFile <- mdForwardRefOrNull ctx mt <$> parseField r 3 numeric- dictLine <- parseField r 4 numeric- dictScope <- mdForwardRefOrNull ctx mt <$> parseField r 5 numeric- dictBaseType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric- dictSize <- parseField r 7 numeric- dictAlign <- parseField r 8 numeric- dictOffset <- parseField r 9 numeric- dictFlags <- parseField r 10 numeric- dictElements <- mdForwardRefOrNull ctx mt <$> parseField r 11 numeric- dictRuntimeLang <- parseField r 12 numeric- dictVTableHolder <- mdForwardRefOrNull ctx mt <$> parseField r 13 numeric- dictTemplateParams <- mdForwardRefOrNull ctx mt <$> parseField r 14 numeric- dictIdentifier <- mdStringOrNull ctx mt <$> parseField r 15 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoCompositeType DICompositeType{..})) pm-- 19 -> label "METADATA_SUBROUTINE_TYPE" $ do- ctx <- getContext- isDistinct <- parseField r 0 nonzero- distFlags <- parseField r 1 numeric- distTypeArray <- mdForwardRefOrNull ctx mt <$> parseField r 2 numeric- return $! updateMetadataTable- (addDebugInfo- isDistinct- (DebugInfoSubroutineType DISubroutineType{..}))- pm-- 20 -> label "METADATA_COMPILE_UNIT" $ do- let recordSize = length (recordFields r)-- -- TODO: update this for llvm-4.0, which bumped the upper bound to 18- when (recordSize < 14 || recordSize > 18)- (fail "Invalid record")-- ctx <- getContext- isDistinct <- parseField r 0 nonzero- dicuLanguage <- parseField r 1 numeric- dicuFile <-- mdForwardRefOrNull ctx mt <$> parseField r 2 numeric- dicuProducer <- mdStringOrNull ctx mt <$> parseField r 3 numeric- dicuIsOptimized <- parseField r 4 nonzero- dicuFlags <- mdStringOrNull ctx mt <$> parseField r 5 numeric- dicuRuntimeVersion <- parseField r 6 numeric- dicuSplitDebugFilename <- mdStringOrNull ctx mt <$> parseField r 7 numeric- dicuEmissionKind <- parseField r 8 numeric- dicuEnums <-- mdForwardRefOrNull ctx mt <$> parseField r 9 numeric- dicuRetainedTypes <-- mdForwardRefOrNull ctx mt <$> parseField r 10 numeric- dicuSubprograms <-- mdForwardRefOrNull ctx mt <$> parseField r 11 numeric- dicuGlobals <-- mdForwardRefOrNull ctx mt <$> parseField r 12 numeric- dicuImports <-- mdForwardRefOrNull ctx mt <$> parseField r 13 numeric- dicuMacros <-- if recordSize <= 15- then pure Nothing- else mdForwardRefOrNull ctx mt <$> parseField r 15 numeric- dicuDWOId <-- if recordSize <= 14- then pure 0- else parseField r 14 numeric- dicuSplitDebugInlining <-- if recordSize <= 16- then pure True- else parseField r 16 nonzero- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoCompileUnit DICompileUnit {..})) pm--- 21 -> label "METADATA_SUBPROGRAM" $ do- -- this one is a bit funky:- -- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2186- let recordSize = length (recordFields r)- adj i | recordSize == 19 = i + 1- | otherwise = i- hasThisAdjustment = recordSize >= 20- unless (18 <= recordSize && recordSize <= 20)- (fail "Invalid record")-- ctx <- getContext- isDistinct <- parseField r 0 nonzero- dispScope <- mdForwardRefOrNull ctx mt <$> parseField r 1 numeric- dispName <- mdStringOrNull ctx mt <$> parseField r 2 numeric- dispLinkageName <- mdStringOrNull ctx mt <$> parseField r 3 numeric- dispFile <- mdForwardRefOrNull ctx mt <$> parseField r 4 numeric- dispLine <- parseField r 5 numeric- dispType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric- dispIsLocal <- parseField r 7 nonzero- dispIsDefinition <- parseField r 8 nonzero- dispScopeLine <- parseField r 9 numeric- dispContainingType <- mdForwardRefOrNull ctx mt <$> parseField r 10 numeric- dispVirtuality <- parseField r 11 numeric- dispVirtualIndex <- parseField r 12 numeric- dispThisAdjustment <- if hasThisAdjustment- then parseField r 19 numeric- else return 0- dispFlags <- parseField r 13 numeric- dispIsOptimized <- parseField r 14 nonzero- dispTemplateParams <-- mdForwardRefOrNull ctx mt <$> parseField r (adj 15) numeric- dispDeclaration <-- mdForwardRefOrNull ctx mt <$> parseField r (adj 16) numeric- dispVariables <-- mdForwardRefOrNull ctx mt <$> parseField r (adj 17) numeric- -- TODO: in the LLVM parser, it then goes into the metadata table- -- and updates function entries to point to subprograms. Is that- -- neccessary for us?- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoSubprogram DISubprogram{..})) pm-- 22 -> label "METADATA_LEXICAL_BLOCK" $ do- when (length (recordFields r) /= 5)- (fail "Invalid record")- cxt <- getContext- isDistinct <- parseField r 0 nonzero- dilbScope <- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric- dilbFile <- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric- dilbLine <- parseField r 3 numeric- dilbColumn <- parseField r 4 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoLexicalBlock DILexicalBlock{..})) pm-- 23 -> label "METADATA_LEXICAL_BLOCK_FILE" $ do- when (length (recordFields r) /= 4)- (fail "Invalid record")- cxt <- getContext- isDistinct <- parseField r 0 nonzero- dilbfScope <- do- mScope <- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric- maybe (fail "Invalid record: scope field not present") return mScope- dilbfFile <- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric- dilbfDiscriminator <- parseField r 3 numeric- return $! updateMetadataTable- (addDebugInfo- isDistinct- (DebugInfoLexicalBlockFile DILexicalBlockFile{..}))- pm-- 24 -> label "METADATA_NAMESPACE" $ do- -- cxt <- getContext- -- isDistinct <- parseField r 0 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric- -- parseField r 3 string- -- parseField r 4 numeric- -- TODO- fail "not yet implemented"- 25 -> label "METADATA_TEMPLATE_TYPE" $ do- -- isDistinct <- parseField r 0 numeric- -- parseField r 1 string- -- getDITypeRefOrNull <$> parseField r 2 numeric- -- TODO- fail "not yet implemented"- 26 -> label "METADATA_TEMPLATE_VALUE" $ do- -- cxt <- getContext- -- isDistinct <- parseField r 0 numeric- -- parseField r 1 numeric- -- parseField r 2 string- -- getDITypeRefOrNull cxt mt <$> parseField r 3 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 4 numeric- -- TODO- fail "not yet implemented"-- 27 -> label "METADATA_GLOBAL_VAR" $ do- let len = length (recordFields r)- unless (11 <= len && len <= 12)- (fail "Unexpected number of record fields")-- ctx <- getContext- field0 <- parseField r 0 numeric- let isDistinct = testBit field0 0- _version = shiftR field0 1 :: Int-- digvScope <- mdForwardRefOrNull ctx mt <$> parseField r 1 numeric- digvName <- mdStringOrNull ctx mt <$> parseField r 2 numeric- digvLinkageName <- mdStringOrNull ctx mt <$> parseField r 3 numeric- digvFile <- mdForwardRefOrNull ctx mt <$> parseField r 4 numeric- digvLine <- parseField r 5 numeric- digvType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric- digvIsLocal <- parseField r 7 nonzero- digvIsDefinition <- parseField r 8 nonzero- digvVariable <- mdForwardRefOrNull ctx mt <$> parseField r 9 numeric- digvDeclaration <- mdForwardRefOrNull ctx mt <$> parseField r 10 numeric- digvAlignment <- if len > 11 then Just <$> parseField r 11 numeric- else return Nothing- return $! updateMetadataTable- (addDebugInfo- isDistinct- (DebugInfoGlobalVariable DIGlobalVariable{..})) pm-- 28 -> label "METADATA_LOCAL_VAR" $ do- -- this one is a bit funky:- -- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2308- let recordSize = length (recordFields r)- when (recordSize < 8 || recordSize > 10)- (fail "Invalid record")-- ctx <- getContext-- field0 <- parseField r 0 numeric- let isDistinct = testBit (field0 :: Word32) 0- hasAlignment = testBit (field0 :: Word32) 1-- hasTag | not hasAlignment && recordSize > 8 = 1- | otherwise = 0-- adj i = i + hasTag-- _alignInBits <-- if hasAlignment- then do n <- parseField r (adj 8) numeric- when ((n :: Word64) > fromIntegral (maxBound :: Word32))- (fail "Alignment value is too large")- return (fromIntegral n :: Word32)-- else return 0-- dilvScope <- mdForwardRefOrNull ("dilvScope":ctx) mt <$> parseField r (adj 1) numeric- dilvName <- mdStringOrNull ("dilvName" :ctx) mt <$> parseField r (adj 2) numeric- dilvFile <- mdForwardRefOrNull ("dilvFile" :ctx) mt <$> parseField r (adj 3) numeric- dilvLine <- parseField r (adj 4) numeric- dilvType <- mdForwardRefOrNull ("dilvType" :ctx) mt <$> parseField r (adj 5) numeric- dilvArg <- parseField r (adj 6) numeric- dilvFlags <- parseField r (adj 7) numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoLocalVariable DILocalVariable{..})) pm-- 29 -> label "METADATA_EXPRESSION" $ do- let recordSize = length (recordFields r)- when (recordSize < 1)- (fail "Invalid record")- isDistinct <- parseField r 0 nonzero- dieElements <- parseFields r 1 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoExpression DIExpression{..})) pm-- 30 -> label "METADATA_OBJC_PROPERTY" $ do- -- TODO- fail "not yet implemented"- 31 -> label "METADATA_IMPORTED_ENTITY" $ do- -- cxt <- getContext- -- isDistinct <- parseField r 0 numeric- -- parseField r 1 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric- -- getDITypeRefOrNull cxt mt <$> parseField r 3 numeric- -- parseField r 4 numeric- -- parseField r 5 string- -- TODO- fail "not yet implemented"- 32 -> label "METADATA_MODULE" $ do- -- cxt <- getContext- -- isDistinct <- parseField r 0 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric- -- parseField r 2 string- -- parseField r 3 string- -- parseField r 4 string- -- parseField r 5 string- -- TODO- fail "not yet implemented"- 33 -> label "METADATA_MACRO" $ do- -- isDistinct <- parseField r 0 numeric- -- parseField r 1 numeric- -- parseField r 2 numeric- -- parseField r 3 string- -- parseField r 4 string- -- TODO- fail "not yet implemented"- 34 -> label "METADATA_MACRO_FILE" $ do- -- cxt <- getContext- -- isDistinct <- parseField r 0 numeric- -- parseField r 1 numeric- -- parseField r 2 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 3 numeric- -- mdForwardRefOrNull cxt mt <$> parseField r 4 numeric- -- TODO- fail "not yet implemented"-- 35 -> label "METADATA_STRINGS" $ do- when (length (recordFields r) /= 3)- (fail "Invalid record: metadata strings layout")- count <- parseField r 0 numeric- offset <- parseField r 1 numeric- bs <- parseField r 2 fieldBlob- when (count == 0)- (fail "Invalid record: metadata strings with no strings")- when (offset >= S.length bs)- (fail "Invalid record: metadata strings corrupt offset")- let (bsLengths, bsStrings) = S.splitAt offset bs- lengths <- either fail return $ parseMetadataStringLengths count bsLengths- when (sum lengths > S.length bsStrings)- (fail "Invalid record: metadata strings truncated")- let strings = snd (mapAccumL f bsStrings lengths)- where f s i = case S.splitAt i s of- (str,rest) -> (rest, Char8.unpack str)- return $! updateMetadataTable (addStrings strings) pm-- -- [ valueid, n x [id, mdnode] ]- 36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do-- -- the record will always be of odd length- when (mod (length (recordFields r)) 2 == 0)- (fail "Invalid record")-- valueId <- parseField r 0 numeric- sym <- case lookupValueTableAbs valueId vt of- Just (Typed { typedValue = ValSymbol sym }) -> return sym- _ -> fail "Non-global referenced"-- refs <- parseGlobalObjectAttachment mt r-- return $! addGlobalAttachments sym refs pm-- 37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do- when (length (recordFields r) /= 3)- (fail "Invalid record: unsupported layout")- cxt <- getContext- isDistinct <- parseField r 0 nonzero- digveVariable <- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric- digveExpression <- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric- return $! updateMetadataTable- (addDebugInfo isDistinct (DebugInfoGlobalVariableExpression DIGlobalVariableExpression{..})) pm-- 38 -> label "METADATA_INDEX_OFFSET" $ do-- when (length (recordFields r) /= 2)- (fail "Invalid record")-- a <- parseField r 0 numeric- b <- parseField r 1 numeric- let _offset = a + (b `shiftL` 32) :: Word64-- -- TODO: is it OK to skip this if we always parse everything?- return pm--- -- In the llvm source, this node is processed when the INDEX_OFFSET record is- -- found.- 39 -> label "METADATA_INDEX" $ do- -- TODO: is it OK to skip this if we always parse everything?- return pm-- code -> fail ("unknown record code: " ++ show code)--parseMetadataEntry _ _ pm (abbrevDef -> Just _) =- return pm--parseMetadataEntry _ _ _ r =- fail ("unexpected: " ++ show r)--parseAttachment :: Record -> Int -> Parse [(PKindMd,PValMd)]-parseAttachment r l = loop (length (recordFields r) - 1) []- where- loop n acc | n < l = return acc- | otherwise = do- kind <- parseField r (n - 1) numeric- md <- getMetadata =<< parseField r n numeric- loop (n - 2) ((kind,typedValue md) : acc)----- | This is a named version of the metadata list that can show up at the end of--- a global declaration. It will be of the form @!dbg !2 [!dbg !n, ...]@.-parseGlobalObjectAttachment :: MetadataTable -> Record -> Parse (Map.Map KindMd PValMd)-parseGlobalObjectAttachment mt r = label "parseGlobalObjectAttachment" $- do cxt <- getContext- go cxt Map.empty 1- where- len = length (recordFields r)-- go cxt acc n | n < len =- do kind <- getKind =<< parseField r n numeric- i <- parseField r (n + 1) numeric- go cxt (Map.insert kind (mdForwardRef cxt mt i) acc) (n + 2)-- go _ acc _ =- return acc----- | Parse a metadata node.-parseMetadataNode :: Bool -> MetadataTable -> Record -> PartialMetadata- -> Parse PartialMetadata-parseMetadataNode isDistinct mt r pm = do- ixs <- parseFields r 0 numeric- cxt <- getContext- let lkp = mdForwardRefOrNull cxt mt- return $! updateMetadataTable (addNode isDistinct (map lkp ixs)) pm----- | Parse out a metadata node in the old format.-parseMetadataOldNode :: Bool -> ValueTable -> MetadataTable -> Record- -> PartialMetadata -> Parse PartialMetadata-parseMetadataOldNode fnLocal vt mt r pm = do- values <- loop =<< parseFields r 0 numeric- return $! updateMetadataTable (addOldNode fnLocal values) pm- where- loop fs = case fs of-- tyId:valId:rest -> do- cxt <- getContext- ty <- getType' tyId- val <- case ty of- PrimType Metadata -> return $ Typed (PrimType Metadata)- (ValMd (mdForwardRef cxt mt valId))- -- XXX need to check for a void type here- _ -> return (forwardRef cxt valId vt)-- vals <- loop rest- return (val:vals)-- [] -> return []-- _ -> fail "Malformed metadata node"--parseMetadataKindEntry :: Record -> Parse ()-parseMetadataKindEntry r = do- kind <- parseField r 0 numeric- name <- parseFields r 1 char- addKind kind name+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module Data.LLVM.BitCode.IR.Metadata (+ parseMetadataBlock+ , parseMetadataKindEntry+ , PartialUnnamedMd(..)+ , finalizePartialUnnamedMd+ , finalizePValMd+ , dedupMetadata+ , InstrMdAttachments+ , PFnMdAttachments+ , PKindMd+ , PGlobalAttachments+ ) where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.IR.Constants+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST+import Text.LLVM.Labels++import qualified Codec.Binary.UTF8.String as UTF8 (decode)+import Control.Applicative ((<|>))+import Control.Exception (throw)+import Control.Monad (foldM, guard, mplus, when)+import Data.Bits (shiftR, testBit, shiftL, (.&.), (.|.), bit, complement)+import Data.Data (Data)+import Data.Typeable (Typeable)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as Char8 (unpack)+import Data.Either (partitionEithers)+import Data.Generics.Uniplate.Data+import qualified Data.IntMap as IntMap+import Data.List (mapAccumL, foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+import Data.Word (Word8,Word32,Word64)++import GHC.Generics (Generic)+import GHC.Stack (HasCallStack, callStack)+import Data.Bifunctor (bimap)++++-- Parsing State ---------------------------------------------------------------++data MetadataTable = MetadataTable+ { mtEntries :: MdTable+ , mtNextNode :: !Int+ , mtNodes :: IntMap.IntMap (Bool, Bool, Int)+ -- ^ 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 -} ->+ MdTable -> MetadataTable+emptyMetadataTable globals es = MetadataTable+ { mtEntries = es+ , mtNextNode = globals+ , mtNodes = IntMap.empty+ }++metadata :: PValMd -> Typed PValue+metadata = Typed (PrimType Metadata) . ValMd++addMetadata :: PValMd -> MetadataTable -> (Int,MetadataTable)+addMetadata val mt = (ix, mt { mtEntries = es' })+ where+ (ix,es') = addValue' (metadata val) (mtEntries mt)++addMdValue :: Typed PValue -> MetadataTable -> MetadataTable+addMdValue tv mt = mt { mtEntries = addValue tv' (mtEntries mt) }+ where+ -- explicitly make a metadata value out of a normal value+ tv' = Typed { typedType = PrimType Metadata+ , typedValue = ValMd (ValMdValue tv)+ }++nameNode :: Bool -> Bool -> Int -> MetadataTable -> MetadataTable+nameNode fnLocal isDistinct ix mt = mt+ { mtNodes = IntMap.insert ix (fnLocal,isDistinct,mtNextNode mt) (mtNodes mt)+ , mtNextNode = mtNextNode mt + 1+ }++addString :: String -> PartialMetadata -> PartialMetadata+addString str pm =+ let (ix, mt) = addMetadata (ValMdString str) (pmEntries pm)+ in pm { pmEntries = mt+ , pmStrings = Map.insert ix str (pmStrings pm)+ }++addStrings :: [String] -> PartialMetadata -> PartialMetadata+addStrings strs pm = foldl' (flip addString) pm strs++addLoc :: Bool -> PDebugLoc -> MetadataTable -> MetadataTable+addLoc isDistinct loc mt = nameNode False isDistinct ix mt'+ where+ (ix,mt') = addMetadata (ValMdLoc loc) mt++addDebugInfo+ :: Bool+ -> DebugInfo' Int+ -> MetadataTable+ -> MetadataTable+addDebugInfo isDistinct di mt = nameNode False isDistinct ix mt'+ where+ (ix,mt') = addMetadata (ValMdDebugInfo di) mt++-- | A variant of 'addDebugInfo' that only inserts the 'DebugInfo' into the+-- 'mtEntries', not the 'mtNodes'. This has the effect of causing the+-- 'DebugInfo' /not/ to be added to any top-level metadata lists and instead+-- causing it to be printed inline wherever it occurs.+-- See @Note [Printing metadata inline]@.+addInlineDebugInfo :: DebugInfo' Int -> MetadataTable -> MetadataTable+addInlineDebugInfo di mt = mt { mtEntries = addValue tv (mtEntries mt) }+ where+ tv = Typed { typedType = PrimType Metadata+ , typedValue = ValMd (ValMdDebugInfo di)+ }++-- | Add a new node, that might be distinct.+addNode :: Bool -> [Maybe PValMd] -> MetadataTable -> MetadataTable+addNode isDistinct vals mt = nameNode False isDistinct ix mt'+ where+ (ix,mt') = addMetadata (ValMdNode vals) mt++addOldNode :: Bool -> [Typed PValue] -> MetadataTable -> MetadataTable+addOldNode fnLocal vals mt = nameNode fnLocal False ix mt'+ where+ (ix,mt') = addMetadata (ValMdNode [ Just (ValMdValue tv) | tv <- vals ]) mt++mdForwardRef :: [String] -> MetadataTable -> Int -> 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+ 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)++mdForwardRefOrNull :: [String] -> MetadataTable -> Int -> Maybe PValMd+mdForwardRefOrNull cxt mt ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1))+ | otherwise = Nothing++mdNodeRef :: HasCallStack+ => [String] -> MetadataTable -> Int -> Int+mdNodeRef cxt mt ix = maybe except prj (IntMap.lookup ix (mtNodes mt))+ where explanation = "Bad forward reference into mtNodes"+ except = throw (BadValueRef callStack cxt explanation ix)+ prj (_, _, x) = x++mdString :: HasCallStack+ => [String] -> PartialMetadata -> Int -> String+mdString cxt partialMeta ix =+ let explanation = "Null value when metadata string was expected"+ in fromMaybe (throw (BadValueRef callStack cxt explanation ix))+ (mdStringOrNull cxt partialMeta ix)++-- | This preferentially fetches the string from the strict string table+-- (@pmStrings@), but will return a forward reference when it can't find it there.+mdStringOrNull :: HasCallStack+ => [String]+ -> PartialMetadata+ -> Int+ -> 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)++mdStringOrEmpty :: HasCallStack+ => [String]+ -> PartialMetadata+ -> Int+ -> String+mdStringOrEmpty cxt partialMeta = fromMaybe "" . mdStringOrNull cxt partialMeta++mkMdRefTable :: MetadataTable -> MdRefTable+mkMdRefTable mt = IntMap.mapMaybe step (mtNodes mt)+ where+ step (fnLocal,_,ix) = do+ guard (not fnLocal)+ return ix++data PartialMetadata = PartialMetadata+ { pmEntries :: MetadataTable+ , pmNamedEntries :: Map.Map String [Int]+ , pmNextName :: Maybe String+ , pmInstrAttachments :: InstrMdAttachments+ , pmFnAttachments :: PFnMdAttachments+ , pmGlobalAttachments:: PGlobalAttachments+ , pmStrings :: Map Int 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+ -- references into other 'pmEntries', allowing them to be strict.+ --+ -- See this comment:+ -- - https://github.com/llvm-mirror/llvm/blob/release_40/lib/Bitcode/Reader/MetadataLoader.cpp#L913+ -- - https://github.com/llvm-mirror/llvm/blob/release_60/lib/Bitcode/Reader/MetadataLoader.cpp#L1017+ } deriving (Show)++emptyPartialMetadata ::+ Int {- ^ globals seen so far -} ->+ MdTable -> PartialMetadata+emptyPartialMetadata globals es = PartialMetadata+ { pmEntries = emptyMetadataTable globals es+ , pmNamedEntries = Map.empty+ , pmNextName = Nothing+ , pmInstrAttachments = Map.empty+ , pmFnAttachments = Map.empty+ , pmGlobalAttachments = Map.empty+ , pmStrings = Map.empty+ }++updateMetadataTable :: (MetadataTable -> MetadataTable)+ -> (PartialMetadata -> PartialMetadata)+updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) }++addGlobalAttachments ::+ Symbol {- ^ name of the global to attach to ^ -} ->+ (Map.Map KindMd PValMd) {- ^ metadata references to attach ^ -} ->+ (PartialMetadata -> PartialMetadata)+addGlobalAttachments sym mds pm =+ pm { pmGlobalAttachments = Map.insert sym mds (pmGlobalAttachments pm)+ }++setNextName :: String -> PartialMetadata -> PartialMetadata+setNextName name pm = pm { pmNextName = Just name }++addFnAttachment :: PFnMdAttachments -> PartialMetadata -> PartialMetadata+addFnAttachment att pm =+ -- left-biased union, since the parser overwrites metadata as it encounters it+ pm { pmFnAttachments = Map.union att (pmFnAttachments pm) }++addInstrAttachment :: Int -> [(KindMd,PValMd)]+ -> PartialMetadata -> PartialMetadata+addInstrAttachment instr md pm =+ pm { pmInstrAttachments = Map.insert instr md (pmInstrAttachments pm) }++nameMetadata :: [Int] -> PartialMetadata -> Parse PartialMetadata+nameMetadata val pm = case pmNextName pm of+ Just name -> return $! pm+ { pmNextName = Nothing+ , pmNamedEntries = Map.insert name val (pmNamedEntries pm)+ }+ Nothing -> fail "Expected a metadata name"++-- De-duplicating ---------------------------------------------------------------++-- | This function generically traverses the given unnamed metadata values.+-- When it encounters one with a 'PValMd' inside of it, it looks up that+-- value in the list. If found, it replaces the value with a reference to it.+--+-- Such de-duplication is necessary because the @fallback@ of+-- 'mdForwardRefOrNull' is often called when it is in fact unnecessary, just+-- because the appropriate references aren't available yet.+--+-- This function is concise at the cost of efficiency: In the worst case, every+-- metadata node contains a reference to every other metadata node, and the+-- cost is O(n^2*log(n)) where+-- * n^2 comes from looking at every 'PValMd' inside every 'PartialUnnamedMd'+-- * log(n) is the cost of looking them up in a 'Map'.+dedupMetadata :: Seq PartialUnnamedMd -> Seq PartialUnnamedMd+dedupMetadata pumd = helper (mkPartialUnnamedMdMap pumd) <$> pumd+ where helper pumdMap pum =+ let pumdMap' = Map.delete (pumValues pum) pumdMap -- don't self-reference+ in pum { pumValues = maybeTransform pumdMap' (pumValues pum) }++ -- | 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 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 pumdMap v = case Map.lookup v pumdMap of+ Just idex -> ValMdRef idex+ Nothing -> v++ mkPartialUnnamedMdMap :: Seq PartialUnnamedMd -> Map PValMd Int+ mkPartialUnnamedMdMap =+ foldl' (\mp part -> Map.insert (pumValues part) (pumIndex part) mp) Map.empty++-- Finalizing ---------------------------------------------------------------++namedEntries :: PartialMetadata -> Seq NamedMd+namedEntries = Seq.fromList+ . map (uncurry NamedMd)+ . Map.toList+ . pmNamedEntries++data PartialUnnamedMd = PartialUnnamedMd+ { pumIndex :: Int+ , pumValues :: PValMd+ , pumDistinct :: Bool+ } deriving (Data, Eq, Ord, Generic, Show, Typeable)++finalizePartialUnnamedMd :: PartialUnnamedMd -> Finalize UnnamedMd+finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` finalizePValMd (pumValues pum)+ where+ mkUnnamedMd v = UnnamedMd+ { umIndex = pumIndex pum+ , umValues = v+ , umDistinct = pumDistinct pum+ }++finalizePValMd :: PValMd -> Finalize ValMd+finalizePValMd = relabel (const requireBbEntryName)++-- | 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))))+ 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))+ -> 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 ref d ix = do+ tv <- lookupValueTableAbs ref (mtEntries mt)+ case tv of+ Typed { typedValue = ValMd v } ->+ pure $! PartialUnnamedMd+ { pumIndex = ix+ , pumValues = v+ , pumDistinct = d+ }+ _ -> error "Impossible: Only ValMds are stored in mtEntries"++type InstrMdAttachments = Map.Map Int [(KindMd,PValMd)]++type PKindMd = Int+type PFnMdAttachments = Map.Map PKindMd PValMd+type PGlobalAttachments = Map.Map Symbol (Map.Map KindMd PValMd)++type ParsedMetadata =+ ( Seq NamedMd+ , (Seq PartialUnnamedMd, Seq PartialUnnamedMd)+ , InstrMdAttachments+ , PFnMdAttachments+ , PGlobalAttachments+ )++parsedMetadata :: PartialMetadata -> ParsedMetadata+parsedMetadata pm =+ ( namedEntries pm+ , unnamedEntries pm+ , pmInstrAttachments pm+ , pmFnAttachments pm+ , pmGlobalAttachments pm+ )++-- Metadata Parsing ------------------------------------------------------------++parseMetadataBlock ::+ Int {- ^ globals seen so far -} ->+ ValueTable -> [Entry] -> Parse ParsedMetadata+parseMetadataBlock globals vt es = label "METADATA_BLOCK" $ do+ ms <- getMdTable+ let pm0 = emptyPartialMetadata globals ms+ rec pm <- foldM (parseMetadataEntry vt (pmEntries pm)) pm0 es+ let entries = pmEntries pm+ setMdTable (mtEntries entries)+ setMdRefs (mkMdRefTable entries)+ return (parsedMetadata pm)++-- | Parse an entry in the metadata block.+--+-- XXX this currently relies on the constant block having been parsed already.+-- Though most bitcode examples I've seen are ordered this way, it would be nice+-- to not have to rely on it.+--+-- Based on the function 'parseOneMetadata' in the LLVM source.+parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry+ -> Parse PartialMetadata+parseMetadataEntry vt mt pm (fromEntry -> Just r) =+ let msg = [ "Are you sure you're using a supported version of LLVM/Clang?"+ , "Check here: https://github.com/GaloisInc/llvm-pretty-bc-parser"+ ]+ assertRecordSizeBetween lb ub =+ let len = length (recordFields r)+ in when (len < lb || ub < len) $+ fail $ unlines $ [ "Invalid record size: " ++ show len+ , "Expected size between " ++ show lb ++ " and " ++ show ub+ ] ++ msg+ assertRecordSizeIn ns =+ let len = length (recordFields r)+ in when (not (len `elem` ns)) $+ fail $ unlines $ [ "Invalid record size: " ++ show len+ , "Expected one of: " ++ show ns+ ] ++ msg++ assertRecordSizeAtLeast lb =+ let len = length (recordFields r)+ in when (len < lb) $+ fail $ unlines $ [ "Invalid record size: " ++ show len+ , "Expected size of " ++ show lb ++ " or greater"+ ] ++ msg++ -- Helper for a common pattern which appears below in the parsing+ ron n = do ctx <- getContext+ mdForwardRefOrNull ctx mt <$> parseField r n numeric++ -- Note: the parsing cases below use a Monadic coding style, as opposed to an+ -- Applicative style (as was originally used) for performance reasons:+ -- Applicative record construction has quadratic size and corresponding+ -- performance impacts (the initial conversion from Applicative to Monadic+ -- saved 11s when parsing a 22MB bitcode file).+ --+ -- Additionally, this module uses RecordWildcards... a pragma that is not+ -- normally advisable but which does work to good effect in this situation to+ -- simplify the following and remove boilerplate intermediary assignments.++ in case recordCode r of+ -- [values]+ 1 -> label "METADATA_STRING" $ do+ str <- fmap UTF8.decode (parseFields r 0 char) `mplus` parseField r 0 string+ return $! addString str pm++ -- [type num, value num]+ 2 -> label "METADATA_VALUE" $ do+ assertRecordSizeIn [2]+ let field = parseField r+ ty <- getType =<< field 0 numeric+ when (ty == PrimType Metadata || ty == PrimType Void)+ (fail "invalid record")++ cxt <- getContext+ ix <- field 1 numeric+ let tv = forwardRef cxt ix vt++ return $! updateMetadataTable (addMdValue tv) pm+++ -- [n x md num]+ 3 -> label "METADATA_NODE" (parseMetadataNode False mt r pm)++ -- [values]+ 4 -> label "METADATA_NAME" $ do+ name <- fmap UTF8.decode (parseFields r 0 char) `mplus` parseField r 0 cstring+ return $! setNextName name pm++ -- [n x md num]+ 5 -> label "METADATA_DISTINCT_NODE" (parseMetadataNode True mt r pm)++ -- [n x [id, name]]+ 6 -> label "METADATA_KIND" $ do+ kind <- parseField r 0 numeric+ name <- UTF8.decode <$> parseFields r 1 char+ addKind kind name+ return pm++ -- [distinct, line, col, scope, inlined-at?]+ 7 -> label "METADATA_LOCATION" $ do+ -- TODO: broken in 3.7+; needs to be a DILocation rather than an+ -- MDLocation, but there appears to be no difference in the+ -- bitcode. /sigh/+ assertRecordSizeIn [5, 6]+ let field = parseField r+ cxt <- getContext+ isDistinct <- field 0 nonzero+ dlLine <- field 1 numeric+ dlCol <- field 2 numeric+ dlScope <- mdForwardRef cxt mt <$> field 3 numeric+ dlIA <- mdForwardRefOrNull cxt mt <$> field 4 numeric+ dlImplicit <- if length (recordFields r) <= 5+ then pure False+ else parseField r 5 nonzero+ let loc = DebugLoc {..}+ return $! updateMetadataTable (addLoc isDistinct loc) pm+++ -- [n x (type num, value num)]+ 8 -> label "METADATA_OLD_NODE" (parseMetadataOldNode False vt mt r pm)++ -- [n x (type num, value num)]+ 9 -> label "METADATA_OLD_FN_NODE" (parseMetadataOldNode True vt mt r pm)++ -- [n x mdnodes]+ 10 -> label "METADATA_NAMED_NODE" $ do+ mdIds <- parseFields r 0 numeric+ cxt <- getContext+ let ids = map (mdNodeRef cxt mt) mdIds+ nameMetadata ids pm++ -- [m x [value, [n x [id, mdnode]]]+ 11 -> label "METADATA_ATTACHMENT" $ do+ let recordSize = length (recordFields r)+ when (recordSize == 0)+ (fail "Invalid record")+ if recordSize `mod` 2 == 0+ then label "function attachment" $ do+ att <- Map.fromList <$> parseAttachment r 0+ return $! addFnAttachment att pm+ else label "instruction attachment" $ do+ inst <- parseField r 0 numeric+ patt <- parseAttachment r 1+ att <- mapM (\(k,md) -> (,md) <$> getKind k) patt+ return $! addInstrAttachment inst att pm++ 12 -> label "METADATA_GENERIC_DEBUG" $ do+ --isDistinct <- parseField r 0 numeric+ --tag <- parseField r 1 numeric+ --version <- parseField r 2 numeric+ --header <- parseField r 3 string+ -- TODO: parse all remaining fields+ fail "not yet implemented"++ 13 -> label "METADATA_SUBRANGE" $ do+ assertRecordSizeIn [3, 5]+ field0 <- parseField r 0 unsigned+ let isDistinct = field0 .&. 0 == 1+ -- The format field determines what set of fields are contained in this+ -- record and what their types are (see+ -- https://github.com/llvm/llvm-project/blob/bbe8cd13/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1437-L1444).+ let format = field0 `shiftR` 1+ let asValMdInt64 x = Just $ ValMdValue+ $ Typed { typedType = PrimType $ Integer 64+ , typedValue = ValInteger x+ }+ diNode <- case format of+ 2 -> do disrCount <- ron 1+ disrLowerBound <- ron 2+ disrUpperBound <- ron 3+ disrStride <- ron 4+ return $ DISubrange {..}+ 1 -> do disrCount <- ron 1+ disrLowerBound <- ron 2+ let disrUpperBound = Nothing+ let disrStride = Nothing+ return $ DISubrange {..}+ 0 -> do disrCount <- asValMdInt64 <$> parseField r 1 numeric+ disrLowerBound <- asValMdInt64 . fromIntegral <$> parseField r 2 signedInt64+ let disrUpperBound = Nothing+ let disrStride = Nothing+ return $ DISubrange {..}+ _ -> fail $ "Unknown format: " <> show format+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoSubrange diNode)) pm++ -- [isBigInt|isUnsigned|distinct, value, name]+ 14 -> label "METADATA_ENUMERATOR" $ do+ assertRecordSizeAtLeast 3+ ctx <- getContext+ flags <- parseField r 0 numeric+ let isDistinct = testBit (flags :: Int) 0+ isUnsigned = testBit (flags :: Int) 1+ isBigInt = testBit (flags :: Int) 2+ name <- mdString ctx pm <$> parseField r 2 numeric+ value <-+ if isBigInt+ -- LLVM 12 or later+ then parseWideInteger r 3+ -- Pre-LLVM 12+ else toInteger <$> parseField r 1 signedInt64+ let diEnum = DebugInfoEnumerator name value isUnsigned+ return $! updateMetadataTable (addDebugInfo isDistinct diEnum) pm++ 15 -> label "METADATA_BASIC_TYPE" $ do+ assertRecordSizeIn [6, 7]+ ctx <- getContext+ isDistinct <- parseField r 0 nonzero+ dibtTag <- parseField r 1 numeric+ dibtName <- mdString ctx pm <$> parseField r 2 numeric+ dibtSize <- parseField r 3 numeric+ dibtAlign <- parseField r 4 numeric+ dibtEncoding <- parseField r 5 numeric+ dibtFlags <- if length (recordFields r) <= 6+ then pure Nothing+ else Just <$> parseField r 6 numeric+ let dibt = DIBasicType {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoBasicType dibt)) pm++ -- [distinct, filename, directory]+ 16 -> label "METADATA_FILE" $ do+ assertRecordSizeIn [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+ let diFile = DIFile {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoFile diFile)) pm++ 17 -> label "METADATA_DERIVED_TYPE" $ do+ -- While upstream LLVM currently imposes a maximum of 14 records per+ -- entry, we raise this to 15 for the sake of parsing Apple LLVM.+ -- See Note [Apple LLVM].+ assertRecordSizeBetween 12 15+ ctx <- getContext+ isDistinct <- parseField r 0 nonzero+ didtTag <- parseField r 1 numeric+ didtName <- mdStringOrNull ctx pm <$> parseField r 2 numeric+ didtFile <- ron 3+ didtLine <- parseField r 4 numeric+ didtScope <- ron 5+ didtBaseType <- ron 6+ didtSize <- parseField r 7 numeric+ didtAlign <- parseField r 8 numeric+ didtOffset <- parseField r 9 numeric+ didtFlags <- parseField r 10 numeric+ didtExtraData <- ron 11+ didtDwarfAddressSpace <-+ if length (recordFields r) <= 12+ then pure Nothing -- field not present+ else do v <- parseField r 12 numeric+ -- dwarf address space is encoded in bitcode as +1; a value of+ -- zero means there is no dwarf address space present:+ -- https://github.com/llvm/llvm-project/blob/bbe8cd1/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1544-L1548+ -- The AST representation is the actual address space, or Nothing+ -- if there is no address space (indistinguishable from "field+ -- not present" for LLVM 4 and earlier).+ if v == 0+ then return Nothing+ else return $ Just $ v - 1+ didtAnnotations <- if length (recordFields r) <= 13+ then pure Nothing+ else ron 13+ let didt = DIDerivedType {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoDerivedType didt)) pm++ 18 -> label "METADATA_COMPOSITE_TYPE" $ do+ assertRecordSizeBetween 16 22+ ctx <- getContext+ isDistinct <- parseField r 0 nonzero+ dictTag <- parseField r 1 numeric+ dictName <- mdStringOrNull ctx pm <$> parseField r 2 numeric+ dictFile <- ron 3+ dictLine <- parseField r 4 numeric+ dictScope <- ron 5+ dictBaseType <- ron 6+ dictSize <- parseField r 7 numeric+ dictAlign <- parseField r 8 numeric+ dictOffset <- parseField r 9 numeric+ dictFlags <- parseField r 10 numeric+ dictElements <- ron 11+ dictRuntimeLang <- parseField r 12 numeric+ dictVTableHolder <- ron 13+ dictTemplateParams <- ron 14+ dictIdentifier <- mdStringOrNull ctx pm <$> parseField r 15 numeric+ dictDiscriminator <- if length (recordFields r) <= 16+ then pure Nothing+ else ron 16+ dictDataLocation <- if length (recordFields r) <= 17+ then pure Nothing+ else ron 17+ dictAssociated <- if length (recordFields r) <= 18+ then pure Nothing+ else ron 18+ dictAllocated <- if length (recordFields r) <= 19+ then pure Nothing+ else ron 19+ dictRank <- if length (recordFields r) <= 20+ then pure Nothing+ else ron 20+ dictAnnotations <- if length (recordFields r) <= 21+ then pure Nothing+ else ron 21+ let dict = DICompositeType {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoCompositeType dict)) pm++ 19 -> label "METADATA_SUBROUTINE_TYPE" $ do+ assertRecordSizeBetween 3 4+ isDistinct <- parseField r 0 nonzero+ distFlags <- parseField r 1 numeric+ distTypeArray <- ron 2+ let dist = DISubroutineType {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoSubroutineType dist)) pm++ 20 -> label "METADATA_COMPILE_UNIT" $ do+ assertRecordSizeBetween 14 22+ 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+ dicuIsOptimized <- parseField r 4 nonzero+ dicuFlags <- mdStringOrNull ctx pm <$> parseField r 5 numeric+ dicuRuntimeVersion <- parseField r 6 numeric+ dicuSplitDebugFilename <- mdStringOrNull ctx pm <$> parseField r 7 numeric+ dicuEmissionKind <- parseField r 8 numeric+ dicuEnums <- ron 9+ dicuRetainedTypes <- ron 10+ dicuSubprograms <- ron 11+ dicuGlobals <- ron 12+ dicuImports <- ron 13+ dicuMacros <- if recordSize <= 15+ then pure Nothing+ else ron 15+ dicuDWOId <- if recordSize <= 14+ then pure 0+ else parseField r 14 numeric+ dicuSplitDebugInlining <- if recordSize <= 16+ then pure True+ else parseField r 16 nonzero+ dicuDebugInfoForProf <- if recordSize <= 17+ then pure False+ else parseField r 17 nonzero+ dicuNameTableKind <- if recordSize <= 18+ then pure 0+ else parseField r 18 numeric+ dicuRangesBaseAddress <- if recordSize <= 19+ then pure False+ else parseField r 19 nonzero+ dicuSysRoot <- if recordSize <= 20+ then pure Nothing+ else mdStringOrNull ctx pm <$> parseField r 20 numeric+ dicuSDK <- if recordSize <= 21+ then pure Nothing+ else mdStringOrNull ctx pm <$> parseField r 21 numeric+ let dicu = DICompileUnit {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoCompileUnit dicu)) pm+++ 21 -> label "METADATA_SUBPROGRAM" $ do+ -- this one is a bit funky:+ -- https://github.com/llvm/llvm-project/blob/release/10.x/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1486++ assertRecordSizeBetween 18 21++ -- A "version" is encoded in the high-order bits of the isDistinct field.+ version <- parseField r 0 numeric++ let hasSPFlags = (version .&. (0x4 :: Word64)) /= 0;++ (diFlags0, spFlags0) <-+ if hasSPFlags then+ (,) <$> parseField r 11 numeric <*> parseField r 9 numeric+ else+ (,) <$> parseField r (11 + 2) numeric <*> pure 0++ let diFlagMainSubprogram = bit 21 :: Word32+ hasOldMainSubprogramFlag = (diFlags0 .&. diFlagMainSubprogram) /= 0++ -- CF https://github.com/llvm/llvm-project/blob/release/10.x/llvm/include/llvm/IR/DebugInfoFlags.def+ spFlagIsLocal = bit 2+ spFlagIsDefinition = bit 3+ spFlagIsOptimized = bit 4+ spFlagIsMain = bit 8++ dispFlags :: Word32+ dispFlags+ | hasOldMainSubprogramFlag = diFlags0 .&. complement diFlagMainSubprogram+ | otherwise = diFlags0++ spFlags :: Word32+ spFlags+ | hasOldMainSubprogramFlag = spFlags0 .|. spFlagIsMain+ | otherwise = spFlags0++ -- TODO, isMain isn't exposed via DISubprogram+ (dispIsLocal, dispIsDefinition, dispIsOptimized, dispVirtuality, _isMain) <-+ if hasSPFlags then+ let spIsLocal = spFlags .&. spFlagIsLocal /= 0+ spIsDefinition = spFlags .&. spFlagIsDefinition /= 0+ spIsOptimized = spFlags .&. spFlagIsOptimized /= 0+ spIsMain = spFlags .&. spFlagIsMain /= 0+ spVirtuality :: Word8+ spVirtuality = fromIntegral (spFlags .&. 0x3)+ in return (spIsLocal, spIsDefinition, spIsOptimized, spVirtuality, spIsMain)+ else+ do spIsLocal <- parseField r 7 nonzero+ spIsDefinition <- parseField r 8 nonzero+ spIsOptimized <- parseField r 14 nonzero+ spVirtuality <- parseField r 11 numeric+ return (spIsLocal, spIsDefinition, spIsOptimized, spVirtuality, hasOldMainSubprogramFlag)++ let recordSize = length (recordFields r)++ isDistinct = (version .&. 0x1 /= 0) || (spFlags .&. spFlagIsDefinition /= 0)++ hasUnit = version .&. 0x2 /= 0++ offsetA+ | not hasSPFlags = 2+ | otherwise = 0++ offsetB+ | not hasSPFlags && recordSize >= 19 = 3+ | not hasSPFlags = 2+ | otherwise = 0++ -- this doesn't seem to be used in our parser...+ --hasFn+ -- | not hasSPFlags && recordSize >= 19 = not hasUnit+ -- | otherwise = False++ hasThisAdjustment+ | not hasSPFlags = recordSize >= 20+ | otherwise = True++ hasThrownTypes+ | not hasSPFlags = recordSize >= 21+ | otherwise = True++ hasAnnotations+ | not hasSPFlags = False+ | otherwise = recordSize >= 19++ -- Some additional sanity checking+ when (not hasSPFlags && hasUnit)+ (assertRecordSizeBetween 19 21)++ when (hasSPFlags && not hasUnit)+ (fail "DISubprogram record has subprogram flags, but does not have unit. Invalid record.")++ ctx <- getContext++ -- Forward references that depend on the 'version'+ let optFwdRef b n =+ if b+ then mdForwardRefOrNull ctx mt <$> 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+ dispFile <- ron 4+ dispLine <- parseField r 5 numeric+ dispType <- ron 6+ dispScopeLine <- parseField r (7 + offsetA) numeric+ dispContainingType <- ron (8 + offsetA)+ dispVirtualIndex <- parseField r (10 + offsetA) numeric+ dispThisAdjustment <- if hasThisAdjustment+ then parseField r (16 + offsetB) numeric+ else return 0+ dispUnit <- optFwdRef hasUnit (12 + offsetB)+ dispTemplateParams <- ron (13 + offsetB)+ dispDeclaration <- ron (14 + offsetB)+ dispRetainedNodes <- ron (15 + offsetB)+ dispThrownTypes <- optFwdRef hasThrownTypes (17 + offsetB)+ dispAnnotations <- optFwdRef hasAnnotations (18 + offsetB)++ let disp = DISubprogram {..}++ -- TODO: in the LLVM parser, it then goes into the metadata table+ -- and updates function entries to point to subprograms. Is that+ -- neccessary for us?+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoSubprogram disp)) pm++ 22 -> label "METADATA_LEXICAL_BLOCK" $ do+ assertRecordSizeIn [5]+ isDistinct <- parseField r 0 nonzero+ dilbScope <- ron 1+ dilbFile <- ron 2+ dilbLine <- parseField r 3 numeric+ dilbColumn <- parseField r 4 numeric+ let dilb = DILexicalBlock {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoLexicalBlock dilb)) pm++ 23 -> label "METADATA_LEXICAL_BLOCK_FILE" $ do+ assertRecordSizeIn [4]+ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ dilbfScope <- mdForwardRef cxt mt <$> parseField r 1 numeric+ dilbfFile <- ron 2+ dilbfDiscriminator <- parseField r 3 numeric+ let dilbf = DILexicalBlockFile {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoLexicalBlockFile dilbf)) pm++ 24 -> label "METADATA_NAMESPACE" $ do+ assertRecordSizeIn [3, 5]+ let isNew =+ case length (recordFields r) of+ 3 -> True+ 5 -> False+ _ -> error "Impossible (METADATA_NAMESPACE)" -- see assertion+ let nameIdx = if isNew then 2 else 3++ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ dinsName <- mdStringOrNull cxt pm <$> parseField r nameIdx numeric+ dinsScope <- mdForwardRef cxt mt <$> parseField r 1 numeric+ dinsFile <- if isNew+ then return (ValMdString "")+ else mdForwardRef cxt mt <$> parseField r 2 numeric+ dinsLine <- if isNew then return 0 else parseField r 4 numeric+ let dins = DINameSpace {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoNameSpace dins)) pm++ 25 -> label "METADATA_TEMPLATE_TYPE" $ do+ assertRecordSizeIn [3, 4]+ let recordLength = length (recordFields r)+ let hasIsDefault | recordLength == 3 = False+ | recordLength == 4 = True+ | otherwise = error "Impossible (METADATA_TEMPLATE_TYPE)" -- see assertion+ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ dittpName <- mdStringOrNull cxt pm <$> parseField r 1 numeric+ dittpType <- ron 2+ dittpIsDefault <- if hasIsDefault+ then Just <$> parseField r 3 boolean+ else pure Nothing+ let dittp = DITemplateTypeParameter {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoTemplateTypeParameter dittp)) pm++ 26 -> label "METADATA_TEMPLATE_VALUE" $ do+ assertRecordSizeIn [5, 6]+ let recordLength = length (recordFields r)+ let hasIsDefault | recordLength == 5 = False+ | recordLength == 6 = True+ | otherwise = error "Impossible (METADATA_TEMPLATE_TYPE)" -- see assertion+ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ ditvpTag <- parseField r 1 numeric+ ditvpName <- mdStringOrNull cxt pm <$> parseField r 2 numeric+ 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+ let ditvp = DITemplateValueParameter {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoTemplateValueParameter ditvp)) pm++ 27 -> label "METADATA_GLOBAL_VAR" $ do+ assertRecordSizeBetween 11 13+ ctx <- getContext+ field0 <- parseField r 0 numeric+ let isDistinct = testBit field0 0+ _version = shiftR field0 1 :: Int++ digvScope <- ron 1+ digvName <- mdStringOrNull ctx pm <$> parseField r 2 numeric+ digvLinkageName <- mdStringOrNull ctx pm <$> parseField r 3 numeric+ digvFile <- ron 4+ digvLine <- parseField r 5 numeric+ digvType <- ron 6+ digvIsLocal <- parseField r 7 nonzero+ digvIsDefinition <- parseField r 8 nonzero+ digvVariable <- ron 9+ digvDeclaration <- ron 10+ digvAlignment <- if length (recordFields r) > 11+ then Just <$> parseField r 11 numeric+ else pure Nothing+ digvAnnotations <- if length (recordFields r) > 12+ then ron 12+ else pure Nothing+ let digv = DIGlobalVariable {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoGlobalVariable digv)) pm++ 28 -> label "METADATA_LOCAL_VAR" $ do+ -- this one is a bit funky:+ -- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2308+ assertRecordSizeBetween 8 10+ ctx <- getContext+ field0 <- parseField r 0 numeric+ let isDistinct = testBit (field0 :: Word32) 0+ hasAlignment = testBit (field0 :: Word32) 1++ hasTag | not hasAlignment && length (recordFields r) > 8 = 1+ | otherwise = 0++ adj i = i + hasTag+++ dilvScope <- mdForwardRefOrNull ("dilvScope":ctx) mt+ <$> parseField r (adj 1) numeric+ dilvName <- mdStringOrNull ("dilvName" :ctx) pm+ <$> parseField r (adj 2) numeric+ dilvFile <- mdForwardRefOrNull ("dilvFile" :ctx) mt+ <$> parseField r (adj 3) numeric+ dilvLine <- parseField r (adj 4) numeric+ dilvType <- mdForwardRefOrNull ("dilvType" :ctx) mt+ <$> parseField r (adj 5) numeric+ dilvArg <- parseField r (adj 6) numeric+ dilvFlags <- parseField r (adj 7) numeric+ dilvAlignment <-+ if hasAlignment+ then do n <- parseField r 8 numeric+ when ((n :: Word64) > fromIntegral (maxBound :: Word32))+ (fail "Alignment value is too large")+ return $ Just (fromIntegral n :: Word32)+ else return Nothing+ dilvAnnotations <- if hasAlignment && length (recordFields r) > 9+ then ron 9+ else pure Nothing+ let dilv = DILocalVariable {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoLocalVariable dilv)) pm++ 29 -> label "METADATA_EXPRESSION" $ do+ {-+ Although DIExpressions store an `isDistinct` field in LLVM bitcode, it is+ never used in practice. This is because DIExpressions are always printed+ inline in definitions, and since the `distinct` keyword is only printed in+ top-level metadata lists, there is no way for `distinct` to be printed+ before a DIExpression. See also Note [Printing metadata inline].+ -}+ -- isDistinct <- parseField r 0 nonzero+ diExpr <- DebugInfoExpression . DIExpression <$> parseFields r 1 numeric+ return $! updateMetadataTable (addInlineDebugInfo diExpr) pm++ 30 -> label "METADATA_OBJC_PROPERTY" $ do+ -- TODO+ fail "not yet implemented"++ 31 -> label "METADATA_IMPORTED_ENTITY" $ do+ assertRecordSizeIn [6, 7]+ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ diieTag <- parseField r 1 numeric+ diieScope <- ron 2+ diieEntity <- ron 3+ diieFile <- if length (recordFields r) >= 7+ then ron 6+ else pure Nothing+ diieLine <- parseField r 4 numeric+ diieName <- mdStringOrNull cxt pm <$> parseField r 5 numeric+ let diie = DIImportedEntity {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoImportedEntity diie)) pm++ 32 -> label "METADATA_MODULE" $ do+ -- cxt <- getContext+ -- isDistinct <- parseField r 0 numeric+ -- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric+ -- parseField r 2 string+ -- parseField r 3 string+ -- parseField r 4 string+ -- parseField r 5 string+ -- TODO+ fail "not yet implemented"+ 33 -> label "METADATA_MACRO" $ do+ -- isDistinct <- parseField r 0 numeric+ -- parseField r 1 numeric+ -- parseField r 2 numeric+ -- parseField r 3 string+ -- parseField r 4 string+ -- TODO+ fail "not yet implemented"+ 34 -> label "METADATA_MACRO_FILE" $ do+ -- cxt <- getContext+ -- isDistinct <- parseField r 0 numeric+ -- parseField r 1 numeric+ -- parseField r 2 numeric+ -- mdForwardRefOrNull cxt mt <$> parseField r 3 numeric+ -- mdForwardRefOrNull cxt mt <$> parseField r 4 numeric+ -- TODO+ fail "not yet implemented"++ 35 -> label "METADATA_STRINGS" $ do+ assertRecordSizeIn [3]+ count <- parseField r 0 numeric+ offset <- parseField r 1 numeric+ bs <- parseField r 2 fieldBlob+ when (count == 0)+ (fail "Invalid record: metadata strings with no strings")+ when (offset > S.length bs)+ (fail "Invalid record: metadata strings corrupt offset")+ let (bsLengths, bsStrings) = S.splitAt offset bs+ lengths <- either fail return $ parseMetadataStringLengths count bsLengths+ when (sum lengths > S.length bsStrings)+ (fail "Invalid record: metadata strings truncated")+ let strings = snd (mapAccumL f bsStrings lengths)+ where f s i = case S.splitAt i s of+ (str, rest) -> (rest, Char8.unpack str)+ return $! addStrings strings pm++ -- [ valueid, n x [id, mdnode] ]+ 36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do++ -- the record will always be of odd length+ when (mod (length (recordFields r)) 2 == 0)+ (fail "Invalid record")++ valueId <- parseField r 0 numeric+ sym <- case lookupValueTableAbs valueId vt of+ Just (Typed { typedValue = ValSymbol sym }) -> return sym+ _ -> fail "Non-global referenced"++ refs <- parseGlobalObjectAttachment mt r++ return $! addGlobalAttachments sym refs pm++ 37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do+ assertRecordSizeIn [3]+ isDistinct <- parseField r 0 nonzero+ digveVariable <- ron 1+ digveExpression <- ron 2+ let digve = DIGlobalVariableExpression {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoGlobalVariableExpression digve)) pm++ 38 -> label "METADATA_INDEX_OFFSET" $ do+ assertRecordSizeIn [2]+ a <- parseField r 0 numeric+ b <- parseField r 1 numeric+ let _offset = a + (b `shiftL` 32) :: Word64++ -- TODO: is it OK to skip this if we always parse everything?+ return pm+++ -- In the llvm source, this node is processed when the INDEX_OFFSET record is+ -- found.+ 39 -> label "METADATA_INDEX" $ do+ -- TODO: is it OK to skip this if we always parse everything?+ return pm++ 40 -> label "METADATA_LABEL" $ do+ assertRecordSizeIn [5]+ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ dilScope <- ron 1+ dilName <- mdString cxt pm <$> parseField r 2 numeric+ dilFile <- ron 3+ dilLine <- parseField r 4 numeric+ let dil = DILabel {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoLabel dil)) pm++ 41 -> label "METADATA_STRING_TYPE" $ do+ notImplemented++ -- 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++ 45 -> label "METADATA_GENERIC_SUBRANGE" $ do+ notImplemented++ 46 -> label "METADATA_ARG_LIST" $ do+ cxt <- getContext+ dial <- DIArgList+ <$> (map (mdForwardRef cxt mt) <$> parseFields r 0 numeric)+ return $! updateMetadataTable+ (addInlineDebugInfo (DebugInfoArgList dial)) pm+++ code -> fail ("unknown record code: " ++ show code)++parseMetadataEntry _ _ pm (abbrevDef -> Just _) =+ return pm++parseMetadataEntry _ _ _ r =+ fail ("unexpected metadata entry: " ++ show r)++parseAttachment :: Record -> Int -> Parse [(PKindMd,PValMd)]+parseAttachment r l = loop (length (recordFields r) - 1) []+ where+ loop n acc | n < l = return acc+ | otherwise = do+ kind <- parseField r (n - 1) numeric+ md <- getMetadata =<< parseField r n numeric+ loop (n - 2) ((kind,typedValue md) : acc)+++-- | This is a named version of the metadata list that can show up at the end of+-- a global declaration. It will be of the form @!dbg !2 [!dbg !n, ...]@.+parseGlobalObjectAttachment :: MetadataTable -> Record -> Parse (Map.Map KindMd PValMd)+parseGlobalObjectAttachment mt r = label "parseGlobalObjectAttachment" $+ do cxt <- getContext+ go cxt Map.empty 1+ where+ len = length (recordFields r)++ go cxt acc n | n < len =+ do kind <- getKind =<< parseField r n numeric+ i <- parseField r (n + 1) numeric+ go cxt (Map.insert kind (mdForwardRef cxt mt i) acc) (n + 2)++ go _ acc _ =+ return acc+++-- | Parse a metadata node.+parseMetadataNode :: Bool -> MetadataTable -> Record -> PartialMetadata+ -> Parse PartialMetadata+parseMetadataNode isDistinct mt r pm = do+ ixs <- parseFields r 0 numeric+ cxt <- getContext+ let lkp = mdForwardRefOrNull cxt mt+ return $! updateMetadataTable (addNode isDistinct (map lkp ixs)) pm+++-- | Parse out a metadata node in the old format.+parseMetadataOldNode :: Bool -> ValueTable -> MetadataTable -> Record+ -> PartialMetadata -> Parse PartialMetadata+parseMetadataOldNode fnLocal vt mt r pm = do+ values <- loop =<< parseFields r 0 numeric+ return $! updateMetadataTable (addOldNode fnLocal values) pm+ where+ loop fs = case fs of++ tyId:valId:rest -> do+ cxt <- getContext+ ty <- getType' tyId+ val <- case ty of+ PrimType Metadata -> return $ Typed (PrimType Metadata)+ (ValMd (mdForwardRef cxt mt valId))+ -- XXX need to check for a void type here+ _ -> return (forwardRef cxt valId vt)++ vals <- loop rest+ return (val:vals)++ [] -> return []++ _ -> fail "Malformed metadata node"++parseMetadataKindEntry :: Record -> Parse ()+parseMetadataKindEntry r = do+ kind <- parseField r 0 numeric+ name <- parseFields r 1 char+ addKind kind (UTF8.decode name)++{-+Note [Apple LLVM]+~~~~~~~~~~~~~~~~~+Apple maintains a fork of LLVM, whose source code can be found at+https://github.com/apple/llvm-project. The version of Clang that is shipped+with Xcode, and thereby the de facto default Clang version on macOS, is based+on this LLVM fork. To distinguish between the two LLVM codebases, we will refer+to "upstream LLVM" and "Apple LLVM" throughout this Note.++One of the more noticeable differences between upstream and Apple LLVM is that+Apple LLVM uses a slightly different bitcode format. In particular, Apple LLVM+has support for pointer authentication+(https://lists.llvm.org/pipermail/llvm-dev/2019-October/136091.html), which+requires adding an extra record to the METADATA_DERIVED_TYPE entry that is not+present in upstream LLVM. This impacts llvm-pretty-bc-parser, as we currently+check that the number of records does not exceed a certain maximum, but this+maximum is different depending on whether we parse upstream or Apple LLVM+bitcode.++For now, we work around this issue by raising the maximum number of+METADATA_DERIVED_TYPE records by one to accommodate Apple LLVM, but we do not+actually parse any information related to pointer authentication. This should+work provided that Apple LLVM continues to encode pointer authentication–related+metadata in the same part of METADATA_DERIVED_TYPE in future releases. If this+assumption does not hold true in the future, we will likely need a more+sophisticated solution that involves parsing the bitcode differently depending+on what Apple LLVM version was used to produce a bitcode file.++Note [Printing metadata inline]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are some forms of metadata that we should always print inline and never+create entries for in top-level metadata lists (named or otherwise). Currently,+these forms of metadata are:++* DIExpression+* DIArgList++This list is taken from the LLVM source code here:+https://github.com/llvm/llvm-project/blob/65600cb2a7e940babf6c493503b9d3fd19f8cb06/llvm/lib/IR/AsmWriter.cpp#L1242-L1245++Implementation-wise, this is accomplished by using `addInlineDebugInfo`. Unlike+`addDebugInfo`, this inserts the metadata field into a separate `mtEntries` map+that is not used to populate top-level metadata lists when pretty-printing an+LLVM module.+-}
src/Data/LLVM/BitCode/IR/Module.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ViewPatterns #-} module Data.LLVM.BitCode.IR.Module where@@ -15,14 +16,16 @@ import Data.LLVM.BitCode.Parse import Data.LLVM.BitCode.Record import Text.LLVM.AST+import Text.LLVM.Triple.AST (TargetTriple)+import Text.LLVM.Triple.Parse (parseTriple) +import qualified Codec.Binary.UTF8.String as UTF8 (decode) import Control.Monad (foldM,guard,when,forM_)-import Data.List (sortBy)-import Data.Monoid (mempty)-import Data.Ord (comparing)+import Data.List (sortOn) import qualified Data.Foldable as F import qualified Data.Map as Map import qualified Data.Sequence as Seq+import Data.Sequence (Seq) import qualified Data.Traversable as T @@ -33,13 +36,15 @@ , partialGlobals :: GlobalList , partialDefines :: DefineList , partialDeclares :: DeclareList+ , partialTriple :: TargetTriple , partialDataLayout :: DataLayout , partialInlineAsm :: InlineAsm+ , partialComdat :: !(Seq (String,SelectionKind)) , partialAliasIx :: !Int , partialAliases :: AliasList- , partialNamedMd :: [NamedMd]- , partialUnnamedMd :: [PartialUnnamedMd]- , partialSections :: Seq.Seq String+ , partialNamedMd :: !(Seq NamedMd)+ , partialUnnamedMd :: !(Seq PartialUnnamedMd)+ , partialSections :: !(Seq String) , partialSourceName :: !(Maybe String) } @@ -49,6 +54,7 @@ , partialGlobals = mempty , partialDefines = mempty , partialDeclares = mempty+ , partialTriple = mempty , partialDataLayout = mempty , partialInlineAsm = mempty , partialAliasIx = 0@@ -57,29 +63,33 @@ , partialUnnamedMd = mempty , partialSections = mempty , partialSourceName = mempty+ , partialComdat = mempty } -- | Fixup the global variables and declarations, and return the completed -- module. finalizeModule :: PartialModule -> Parse Module-finalizeModule pm = do+finalizeModule pm = label "finalizeModule" $ do globals <- T.mapM finalizeGlobal (partialGlobals pm) declares <- T.mapM finalizeDeclare (partialDeclares pm) aliases <- T.mapM finalizePartialAlias (partialAliases pm)- unnamed <- T.mapM finalizePartialUnnamedMd (partialUnnamedMd pm)+ unnamed <- liftFinalize $ T.mapM finalizePartialUnnamedMd (dedupMetadata (partialUnnamedMd pm)) types <- resolveTypeDecls let lkp = lookupBlockName (partialDefines pm) defines <- T.mapM (finalizePartialDefine lkp) (partialDefines pm) return emptyModule- { modDataLayout = partialDataLayout pm- , modNamedMd = partialNamedMd pm- , modUnnamedMd = sortBy (comparing umIndex) unnamed+ { modSourceName = partialSourceName pm+ , modTriple = partialTriple pm+ , modDataLayout = partialDataLayout pm+ , modNamedMd = F.toList (partialNamedMd pm)+ , modUnnamedMd = sortOn umIndex (F.toList unnamed) , modGlobals = F.toList globals , modDefines = F.toList defines , modTypes = types , modDeclares = F.toList declares , modInlineAsm = partialInlineAsm pm , modAliases = F.toList aliases+ , modComdat = Map.fromList (F.toList (partialComdat pm)) } -- | Parse an LLVM Module out of the top-level block in a Bitstream.@@ -94,7 +104,7 @@ Just es -> parseTypeBlock es Nothing -> return mempty - withTypeSymtab tsymtab $ do+ withTypeSymtab tsymtab $ label "value symbol table" $ do -- parse the value symbol table out first, if there is one symtab <- do mb <- match (findMatch valueSymtabBlockId) ents@@ -129,13 +139,12 @@ -- MODULE_CODE_FUNCTION parseFunProto r pm -parseModuleBlockEntry pm (functionBlockId -> Just es) = do- -- FUNCTION_BLOCK_ID+parseModuleBlockEntry pm (functionBlockId -> Just es) = label "FUNCTION_BLOCK_ID" $ do let unnamedGlobalsCount = length (partialUnnamedMd pm) def <- parseFunctionBlock unnamedGlobalsCount es- let def' = def { partialGlobalMd = [] }+ let def' = def { partialGlobalMd = mempty } return pm { partialDefines = partialDefines pm Seq.|> def'- , partialUnnamedMd = partialGlobalMd def ++ partialUnnamedMd pm+ , partialUnnamedMd = partialGlobalMd def <> partialUnnamedMd pm } parseModuleBlockEntry pm (paramattrBlockId -> Just _) = do@@ -148,34 +157,36 @@ -- TODO: skip for now return pm -parseModuleBlockEntry pm (metadataBlockId -> Just es) = do- -- METADATA_BLOCK_ID+parseModuleBlockEntry pm (metadataBlockId -> Just es) = label "METADATA_BLOCK_ID" $ do vt <- getValueTable let globalsSoFar = length (partialUnnamedMd pm) (ns,(gs,_),_,_,atts) <- parseMetadataBlock globalsSoFar vt es return $ addGlobalAttachments atts pm- { partialNamedMd = partialNamedMd pm ++ ns- , partialUnnamedMd = partialUnnamedMd pm ++ gs+ { partialNamedMd = partialNamedMd pm <> ns+ , partialUnnamedMd = partialUnnamedMd pm <> gs } -parseModuleBlockEntry pm (valueSymtabBlockId -> Just _) = do+parseModuleBlockEntry pm (valueSymtabBlockId -> Just _es) = do -- VALUE_SYMTAB_BLOCK_ID+ -- NOTE: we parse the value symbol table eagerly at the beginning of the+ -- MODULE_BLOCK return pm -parseModuleBlockEntry pm (moduleCodeTriple -> Just _) = do+parseModuleBlockEntry pm (moduleCodeTriple -> Just r) = do -- MODULE_CODE_TRIPLE- return pm+ triple <- UTF8.decode <$> parseFields r 0 char+ return (pm { partialTriple = parseTriple triple }) parseModuleBlockEntry pm (moduleCodeDatalayout -> Just r) = do -- MODULE_CODE_DATALAYOUT- layout <- parseFields r 0 char+ layout <- UTF8.decode <$> parseFields r 0 char case parseDataLayout layout of Nothing -> fail ("unable to parse data layout: ``" ++ layout ++ "''") Just dl -> return (pm { partialDataLayout = dl }) parseModuleBlockEntry pm (moduleCodeAsm -> Just r) = do -- MODULE_CODE_ASM- asm <- parseFields r 0 char+ asm <- UTF8.decode <$> parseFields r 0 char return pm { partialInlineAsm = lines asm } parseModuleBlockEntry pm (abbrevDef -> Just _) = do@@ -190,9 +201,8 @@ , partialGlobals = partialGlobals pm Seq.|> pg } -parseModuleBlockEntry pm (moduleCodeAlias -> Just r) = do- -- MODULE_CODE_ALIAS_OLD- pa <- parseAlias (partialAliasIx pm) r+parseModuleBlockEntry pm (moduleCodeAlias -> Just r) = label "MODULE_CODE_ALIAS_OLD" $ do+ pa <- parseAliasOld (partialAliasIx pm) r return pm { partialAliasIx = succ (partialAliasIx pm) , partialAliases = partialAliases pm Seq.|> pa@@ -204,29 +214,38 @@ -- please see: -- http://llvm.org/docs/BitCodeFormat.html#module-code-version-record version <- parseField r 0 numeric+ setModVersion version case version :: Int of 0 -> setRelIds False -- Absolute value ids in LLVM <= 3.2 1 -> setRelIds True -- Relative value ids in LLVM >= 3.3+ 2 -> setRelIds True -- Relative value ids in LLVM >= 5.0 _ -> fail ("unsupported version id: " ++ show version) return pm parseModuleBlockEntry pm (moduleCodeSectionname -> Just r) = do- name <- parseFields r 0 char+ name <- UTF8.decode <$> parseFields r 0 char return pm { partialSections = partialSections pm Seq.|> name } -parseModuleBlockEntry _ (moduleCodeComdat -> Just _) = do+parseModuleBlockEntry pm (moduleCodeComdat -> Just r) = do -- MODULE_CODE_COMDAT- fail "MODULE_CODE_COMDAT"+ when (length (recordFields r) < 2) (fail "Invalid record (MODULE_CODE_COMDAT)")+ -- This was last updated in 0fc96d5, but the implementation appeared a bit+ -- buggy for clang++ 3.8. Since no known downstream consumer uses it, it was+ -- removed.+ return pm parseModuleBlockEntry pm (moduleCodeVSTOffset -> Just _) = do -- MODULE_CODE_VSTOFFSET -- TODO: should we handle this? return pm -parseModuleBlockEntry _ (moduleCodeAliasNew -> Just _) = do- -- MODULE_CODE_ALIAS- fail "MODULE_CODE_ALIAS"+parseModuleBlockEntry pm (moduleCodeAliasNew -> Just r) = label "MODULE_CODE_ALIAS" $ do+ pa <- parseAlias r+ return pm+ { partialAliasIx = succ (partialAliasIx pm)+ , partialAliases = partialAliases pm Seq.|> pa+ } parseModuleBlockEntry pm (moduleCodeMDValsUnused -> Just _) = do -- MODULE_CODE_METADATA_VALUES_UNUSED@@ -237,46 +256,69 @@ do str <- parseField r 0 cstring return pm { partialSourceName = Just str } -parseModuleBlockEntry _ (moduleCodeHash -> Just _) = do+parseModuleBlockEntry pm (moduleCodeHash -> Just _) = do -- MODULE_CODE_HASH- fail "MODULE_CODE_HASH"+ -- It should be safe to ignore this for now.+ --fail "MODULE_CODE_HASH"+ return pm parseModuleBlockEntry _ (moduleCodeIFunc -> Just _) = do -- MODULE_CODE_IFUNC fail "MODULE_CODE_IFUNC" -parseModuleBlockEntry _ (uselistBlockId -> Just _) = do+parseModuleBlockEntry pm (uselistBlockId -> Just _) = do -- USELIST_BLOCK_ID- fail "USELIST_BLOCK_ID"+ -- XXX ?? fail "USELIST_BLOCK_ID"+ return pm parseModuleBlockEntry _ (moduleStrtabBlockId -> Just _) = do -- MODULE_STRTAB_BLOCK_ID fail "MODULE_STRTAB_BLOCK_ID" -parseModuleBlockEntry _ (globalvalSummaryBlockId -> Just _) = do+parseModuleBlockEntry pm (globalvalSummaryBlockId -> Just _) = do -- GLOBALVAL_SUMMARY_BLOCK_ID- fail "GLOBALVAL_SUMMARY_BLOCK_ID"+ -- It should be safe to ignore this for now.+ return pm parseModuleBlockEntry pm (operandBundleTagsBlockId -> Just _) = do -- OPERAND_BUNDLE_TAGS_BLOCK_ID -- fail "OPERAND_BUNDLE_TAGS_BLOCK_ID" return pm -parseModuleBlockEntry pm (metadataKindBlockId -> Just es) = do- -- METADATA_KIND_BLOCK_ID+parseModuleBlockEntry pm (metadataKindBlockId -> Just es) = label "METADATA_KIND_BLOCK_ID" $ do forM_ es $ \e -> case fromEntry e of Just r -> parseMetadataKindEntry r Nothing -> fail "Can't parse metadata kind block entry." return pm -parseModuleBlockEntry _ e =- fail ("unexpected: " ++ show e)+parseModuleBlockEntry pm (strtabBlockId -> Just _) =+ -- Handled already.+ return pm +parseModuleBlockEntry pm (ltoSummaryBlockId -> Just _) =+ -- It should be safe to ignore this for now.+ --label "FULL_LTO_GLOBALVAL_SUMMARY_BLOCK_ID" $ do+ -- fail "FULL_LTO_GLOBALVAL_SUMMARY_BLOCK_ID unsupported"+ return pm +parseModuleBlockEntry pm (symtabBlockId -> Just [symtabBlobId -> Just _]) =+ -- Handled already+ return pm++parseModuleBlockEntry pm (syncScopeNamesBlockId -> Just _) =+ label "SYNC_SCOPE_NAMES_BLOCK_ID" $ do+ -- TODO: record this information somewhere+ return pm++parseModuleBlockEntry _ e =+ fail ("unexpected module block entry: " ++ show e)+ parseFunProto :: Record -> PartialModule -> Parse PartialModule parseFunProto r pm = label "FUNCTION" $ do- let field = parseField r+ ix <- nextValueId+ (name, offset) <- oldOrStrtabName ix r+ let field i = parseField r (i + offset) funTy <- getType =<< field 0 numeric let ty = case funTy of PtrTo _ -> funTy@@ -286,23 +328,29 @@ link <- field 3 linkage + vis <- field 7 visibility+ section <- if length (recordFields r) >= 6- then do ix <- field 6 numeric- if ix == 0+ then do sid <- field 6 numeric+ if sid == 0 then return Nothing- else do let ix' = ix - 1- when (ix' >= Seq.length (partialSections pm))+ else do let sid' = sid - 1+ when (sid' >= length (partialSections pm)) (fail "invalid section name index")- return (Just (Seq.index (partialSections pm) (ix - 1)))+ return (Just (Seq.index (partialSections pm) sid')) else return Nothing -- push the function type- ix <- nextValueId- name <- entryName ix- _ <- pushValue (Typed ty (ValSymbol (Symbol name)))-+ _ <- pushValue (Typed ty (ValSymbol name))+ let lkMb t x+ | length t > x = Just (Seq.index t x)+ | otherwise = Nothing+ comdat <- if length (recordFields r) >= 12+ then do comdatID <- field 12 numeric+ pure (fst <$> partialComdat pm `lkMb` comdatID)+ else pure Nothing let proto = FunProto { protoType = ty , protoLinkage =@@ -310,10 +358,12 @@ -- llvm-dis when linkage is External guard (link /= External) return link+ , protoVisibility = Just vis , protoGC = Nothing- , protoName = name+ , protoSym = name , protoIndex = ix , protoSect = section+ , protoComdat = comdat } if isProto == (0 :: Int)
src/Data/LLVM/BitCode/IR/Types.hs view
@@ -5,18 +5,19 @@ , parseTypeBlock ) where -import Data.LLVM.BitCode.Bitstream-import Data.LLVM.BitCode.Match-import Data.LLVM.BitCode.Parse-import Data.LLVM.BitCode.Record-import Text.LLVM.AST+import qualified Data.LLVM.BitCode.Assert as Assert+import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST -import Control.Monad (when,unless,mplus,(<=<))-import Data.List (sortBy)-import Data.Maybe (catMaybes)-import Data.Monoid (mempty)-import Data.Ord (comparing)-import qualified Data.Map as Map+import qualified Codec.Binary.UTF8.String as UTF8 (decode)+import Control.Monad (when,unless,mplus,(<=<))+import qualified Data.IntMap as IntMap+import Data.List (sortBy)+import Data.Maybe (catMaybes)+import Data.Ord (comparing) -- Type Block ------------------------------------------------------------------@@ -28,7 +29,7 @@ resolveTypeDecls :: Parse [TypeDecl] resolveTypeDecls = do symtab <- getTypeSymtab- decls <- mapM mkTypeDecl (Map.toList (tsById symtab))+ decls <- mapM mkTypeDecl (IntMap.toList (tsById symtab)) return (sortBy (comparing typeName) decls) where mkTypeDecl (ix,alias) = do@@ -75,8 +76,8 @@ -- recursively resolve the type table, if they don't already exist in the -- symbol table. if the index entry doesn't exist, throw an error, as that -- should be impossible.- tt = Map.fromList [ (ix,updateAliases resolve ty) | (ix,(ty,_)) <- ixs ]- resolve ix = case Map.lookup ix (tsById sym) of+ tt = IntMap.fromList [ (ix, updateAliases resolve ty) | (ix, (ty, _)) <- ixs ]+ resolve ix = case IntMap.lookup ix (tsById sym) of Nothing -> lookupTypeRef cxt ix tt Just ident -> Alias ident @@ -116,6 +117,7 @@ let field = parseField r ty <- field 0 typeRef when (length (recordFields r) == 2) $ do+ -- We do not currently store address spaces in the @llvm-pretty@ AST. _space <- field 1 keep return () addType (PtrTo ty)@@ -129,7 +131,7 @@ rty:ptys -> addType (FunTy rty ptys va) _ -> fail "function expects a return type" - 10 -> label "TYPE_CODE_X86_FP80" (addType (PrimType (FloatType Half)))+ 10 -> label "TYPE_CODE_FP_HALF" (addType (PrimType (FloatType Half))) 11 -> label "TYPE_CODE_ARRAY" $ do let field = parseField r@@ -164,7 +166,7 @@ 19 -> label "TYPE_CODE_STRUCT_NAME" $ do name <- label "struct name" $ parseField r 0 cstring- `mplus` parseFields r 0 char+ `mplus` fmap UTF8.decode (parseFields r 0 char) setTypeName name noType @@ -188,7 +190,27 @@ rty:ptys -> addType (FunTy rty ptys vararg) [] -> fail "function expects a return type" - code -> fail ("unknown type code " ++ show code)+ 22 -> label "TYPE_CODE_TOKEN" $ do+ notImplemented++ 23 -> label "TYPE_CODE_BFLOAT" $ do+ notImplemented++ 24 -> label "TYPE_CODE_X86_AMX" $ do+ notImplemented++ 25 -> label "TYPE_CODE_OPAQUE_POINTER" $ do+ let field = parseField r+ when (length (recordFields r) /= 1) $+ fail "Invalid opaque pointer record"+ -- We do not currently store address spaces in the @llvm-pretty@ AST.+ _space <- field 0 keep+ addType PtrOpaque++ 26 -> label "TYPE_CODE_TARGET_TYPE" $ do+ notImplemented++ code -> Assert.unknownEntity "type code " code -- skip blocks parseTypeBlockEntry (block -> Just _) =
src/Data/LLVM/BitCode/IR/Values.hs view
@@ -2,14 +2,11 @@ module Data.LLVM.BitCode.IR.Values ( getValueTypePair- , getConstantFwdRef , getValue- , getFnValueById+ , getFnValueById, getFnValueById' , parseValueSymbolTableBlock ) where -import Data.Word- import Data.LLVM.BitCode.Bitstream import Data.LLVM.BitCode.Match import Data.LLVM.BitCode.Parse@@ -17,79 +14,70 @@ import Text.LLVM.AST import Control.Monad ((<=<),foldM)-import qualified Data.Map as Map -- Value Table ----------------------------------------------------------------- -getConstantFwdRef :: ValueTable -> Type -> Int -> Parse (Typed PValue)-getConstantFwdRef t ty n = label "getConstantFwdRef" $ do- mb <- lookupValue n- case mb of- Just tv -> return tv-- -- forward reference- Nothing -> do- cxt <- getContext- let ref = forwardRef cxt n t- return (Typed ty (typedValue ref))- -- | Get either a value from the value table, with its value, or parse a value -- and a type. getValueTypePair :: ValueTable -> Record -> Int -> Parse (Typed PValue, Int) getValueTypePair t r ix = do let field = parseField r- n <- field ix numeric- mb <- lookupValue n+ n <- adjustId =<< field ix numeric+ mb <- lookupValueAbs n case mb of- -- value++ -- value is already present in the incremental table Just tv -> return (tv, ix+1) - -- forward reference+ -- forward reference to the entry in the final table Nothing -> do ty <- getType =<< field (ix+1) numeric- n' <- adjustId n cxt <- getContext- let ref = forwardRef cxt n' t+ let ref = forwardRef cxt n t -- generate the forward reference to the value only, as we already know -- what the type should be. return (Typed ty (typedValue ref), ix+2) -- | Get a single value from the value table.-getValue :: Type -> Int -> Parse (Typed PValue)-getValue ty n = label "getValue" $ do+--getValueNoFwdRef :: Type -> Int -> Parse (Typed PValue)+--getValueNoFwdRef ty n = label "getValueNoFwdRef" (getFnValueById ty =<< adjustId n) - useRelIds <- getRelIds- cur <- getNextId- -- The relative conversion has to be done on a Word32 to handle overflow- -- when n is large the same way BitcodeReaderMDValueList::getValue does.- let i :: Word32- i | useRelIds = fromIntegral cur - fromIntegral n- | otherwise = fromIntegral n- getFnValueById ty i+getFnValueById :: Type -> Int -> Parse (Typed PValue)+getFnValueById = getFnValueById' Nothing +getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue)+getValue vt ty n = label "getValue" (getFnValueById' (Just vt) ty =<< adjustId n)+ -- | Lookup a value by its absolute id, or perhaps some metadata.-getFnValueById :: Type -> Word32 -> Parse (Typed PValue)-getFnValueById ty n = label "getFnValueById" $ case ty of+getFnValueById' :: Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)+getFnValueById' mbVt ty n = label "getFnValueById'" $ case ty of PrimType Metadata -> do cxt <- getContext md <- getMdTable- return (forwardRef cxt (fromIntegral n) md)+ return (forwardRef cxt n md) _ -> do- mb <- lookupValueAbs (fromIntegral n)+ mb <- lookupValueAbs n case mb of Just tv -> return tv -- forward reference Nothing -> do- name <- entryName (fromIntegral n)- return (Typed ty (ValIdent (Ident name)))+ mbName <- entryNameMb n+ case mbName of+ Just name -> return (Typed ty (ValIdent (Ident name))) + Nothing+ | Just vt <- mbVt ->+ do cxt <- getContext+ return (forwardRef cxt n vt) + | otherwise ->+ fail "Unable to create forward reference" -- Value Symbol Table Entries -------------------------------------------------- @@ -105,22 +93,24 @@ -- Value Symbol Table Parsing -------------------------------------------------- parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab-parseValueSymbolTableBlock = foldM parseValueSymbolTableBlockEntry Map.empty+parseValueSymbolTableBlock = foldM parseValueSymbolTableBlockEntry mempty parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab parseValueSymbolTableBlockEntry vs (vstCodeEntry -> Just r) = do -- VST_ENTRY: [valid, namechar x N]+ -- TODO: fail if version >= 2? These aren't supposed to be around anymore. let field = parseField r valid <- field 0 numeric- name <- field 1 (fieldArray (fieldChar6 ||| char))+ name <- field 1 cstring return (addEntry valid name vs) parseValueSymbolTableBlockEntry vs (vstCodeBBEntry -> Just r) = do -- VST_BBENTRY: [bbid, namechar x N]+ -- TODO: fail if version >= 2? These aren't supposed to be around anymore. let field = parseField r bbid <- field 0 numeric- name <- field 1 (fieldArray (fieldChar6 ||| char))+ name <- field 1 cstring return (addBBEntry bbid name vs) parseValueSymbolTableBlockEntry vs (vstCodeFNEntry -> Just r) = do@@ -128,8 +118,12 @@ let field = parseField r valid <- field 0 numeric offset <- field 1 numeric- name <- field 2 (fieldArray (fieldChar6 ||| char))- return (addFNEntry valid offset name vs)+ case length (recordFields r) of+ 2 -> return (addFwdFNEntry valid offset vs)+ 3 -> do+ name <- field 2 cstring+ return (addFNEntry valid offset name vs)+ _ -> fail "unexpected number of parameters to FNENTRY" parseValueSymbolTableBlockEntry vs (abbrevDef -> Just _) = -- skip abbreviation definitions, they're already resolved
src/Data/LLVM/BitCode/Parse.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -8,27 +9,41 @@ module Data.LLVM.BitCode.Parse where -import Text.LLVM.AST-import Text.LLVM.PP+import Text.LLVM.AST+import Text.LLVM.PP -import Control.Applicative (Applicative(..),Alternative(..),(<$>))-import Control.Monad.Fix (MonadFix)-import Data.Maybe (fromMaybe)-import Data.Monoid (Monoid(..))-import Data.Typeable (Typeable)-import Data.Word ( Word32 )-import MonadLib+import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..), unless)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail -- makes fail visible for instance+#endif+import Control.Monad.Fix (MonadFix)+import Control.Monad.Except (MonadError(..), Except, runExcept)+import Control.Monad.Reader (MonadReader(..), ReaderT(..))+import Control.Monad.State.Strict (MonadState(..), StateT(..))+import Data.Maybe (fromMaybe)+import Data.Semigroup+import Data.Typeable (Typeable)+import Data.Word ( Word32 )++import qualified Codec.Binary.UTF8.String as UTF8 (decode) import qualified Control.Exception as X+import qualified Data.ByteString as BS+import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Sequence as Seq+import GHC.Stack (HasCallStack, CallStack, callStack, prettyCallStack) +import Prelude + -- Error Collection Parser ----------------------------------------------------- data Error = Error { errContext :: [String] , errMessage :: String- } deriving (Show)+ } deriving (Show, Eq, Ord) formatError :: Error -> String formatError err@@ -39,25 +54,33 @@ : map ('\t' :) (errContext err) newtype Parse a = Parse- { unParse :: ReaderT Env (StateT ParseState (ExceptionT Error Lift)) a- } deriving (Functor,Applicative,MonadFix)+ { unParse :: ReaderT Env (StateT ParseState (Except Error)) a+ } deriving (Functor, Applicative, MonadFix) instance Monad Parse where+#if !MIN_VERSION_base(4,11,0) {-# INLINE return #-}- return = Parse . return+ return = pure+#endif {-# INLINE (>>=) #-} Parse m >>= f = Parse (m >>= unParse . f) +#if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail = failWithContext+#endif +instance MonadFail Parse where+ {-# INLINE fail #-}+ fail = failWithContext+ instance Alternative Parse where {-# INLINE empty #-} empty = failWithContext "empty" {-# INLINE (<|>) #-}- a <|> b = Parse (either (const (unParse b)) return =<< try (unParse a))+ a <|> b = Parse $ catchError (unParse a) (const (unParse b)) instance MonadPlus Parse where {-# INLINE mzero #-}@@ -67,9 +90,10 @@ mplus = (<|>) runParse :: Parse a -> Either Error a-runParse (Parse m) = case runM m emptyEnv emptyParseState of- Left err -> Left err- Right (a,_) -> Right a+runParse (Parse m) =+ case runExcept (runStateT (runReaderT m emptyEnv) emptyParseState) of+ Left err -> Left err+ Right (a, _) -> Right a notImplemented :: Parse a notImplemented = fail "not implemented"@@ -80,6 +104,7 @@ { psTypeTable :: TypeTable , psTypeTableSize :: !Int , psValueTable :: ValueTable+ , psStringTable :: Maybe StringTable , psMdTable :: ValueTable , psMdRefs :: MdRefTable , psFunProtos :: Seq.Seq FunProto@@ -88,29 +113,32 @@ , psNextTypeId :: !Int , psLastLoc :: Maybe PDebugLoc , psKinds :: !KindTable+ , psModVersion :: !Int } deriving (Show) -- | The initial parsing state. emptyParseState :: ParseState emptyParseState = ParseState- { psTypeTable = Map.empty+ { psTypeTable = IntMap.empty , psTypeTableSize = 0 , psValueTable = emptyValueTable False+ , psStringTable = Nothing , psMdTable = emptyValueTable False- , psMdRefs = Map.empty+ , psMdRefs = IntMap.empty , psFunProtos = Seq.empty , psNextResultId = 0 , psTypeName = Nothing , psNextTypeId = 0 , psLastLoc = Nothing , psKinds = emptyKindTable+ , psModVersion = 0 } -- | The next implicit result id. nextResultId :: Parse Int nextResultId = Parse $ do ps <- get- set ps { psNextResultId = psNextResultId ps + 1 }+ put ps { psNextResultId = psNextResultId ps + 1 } return (psNextResultId ps) type PDebugLoc = DebugLoc' Int@@ -118,37 +146,45 @@ setLastLoc :: PDebugLoc -> Parse () setLastLoc loc = Parse $ do ps <- get- set $! ps { psLastLoc = Just loc }+ put $! ps { psLastLoc = Just loc } setRelIds :: Bool -> Parse () setRelIds b = Parse $ do ps <- get- set $! ps { psValueTable = (psValueTable ps) { valueRelIds = b }}+ put $! ps { psValueTable = (psValueTable ps) { valueRelIds = b }} getRelIds :: Parse Bool-getRelIds = Parse $ do- ps <- get+getRelIds = do+ ps <- Parse get return (valueRelIds (psValueTable ps)) getLastLoc :: Parse PDebugLoc-getLastLoc = Parse $ do- ps <- get+getLastLoc = do+ ps <- Parse get case psLastLoc ps of Just loc -> return loc Nothing -> fail "No last location available" +setModVersion :: Int -> Parse ()+setModVersion v = Parse $ do+ ps <- get+ put $! ps { psModVersion = v }++getModVersion :: Parse Int+getModVersion = Parse (psModVersion <$> get)+ -- | Sort of a hack to preserve state between function body parses. It would -- really be nice to separate this into a different monad, that could just run -- under the Parse monad, but sort of unnecessary in the long run. enterFunctionDef :: Parse a -> Parse a enterFunctionDef m = Parse $ do ps <- get- set ps+ put ps { psNextResultId = 0 } res <- unParse m ps' <- get- set ps'+ put ps' { psValueTable = psValueTable ps , psMdTable = psMdTable ps , psMdRefs = psMdRefs ps@@ -159,35 +195,47 @@ -- Type Table ------------------------------------------------------------------ -type TypeTable = Map.Map Int Type+type TypeTable = IntMap.IntMap Type -- | Generate a type table, and a type symbol table. mkTypeTable :: [Type] -> TypeTable-mkTypeTable = Map.fromList . zip [0 ..]+mkTypeTable = IntMap.fromList . zip [0 ..] +-- | Exceptions contain a callstack, parsing context, explanation, and index data BadForwardRef- = BadTypeRef [String] Int- | BadValueRef [String] Int+ = BadTypeRef CallStack [String] String Int+ | BadValueRef CallStack [String] String Int deriving (Show,Typeable) instance X.Exception BadForwardRef badRefError :: BadForwardRef -> Error-badRefError ref = case ref of- BadTypeRef c i -> Error c ("bad forward reference to type: " ++ show i)- BadValueRef c i -> Error c ("bad forward reference to value: " ++ show i)+badRefError ref =+ let (stk, cxt, explanation, i, thing) =+ case ref of+ BadTypeRef stk' cxt' explanation' i' -> (stk', cxt', explanation', i', "type")+ BadValueRef stk' cxt' explanation' i' -> (stk', cxt', explanation', i', "value")+ in Error cxt $ unlines ["bad forward reference to " ++ thing ++ ": " ++ show i+ , "additional details: "+ , explanation+ , "with call stack: "+ , prettyCallStack stk+ ] -- | As type tables are always pre-allocated, looking things up should never -- fail. As a result, the worst thing that could happen is that the type entry -- causes a runtime error. This is pretty bad, but it's an acceptable trade-off -- for the complexity of the forward references in the type table.-lookupTypeRef :: [String] -> Int -> TypeTable -> Type-lookupTypeRef cxt n = fromMaybe (X.throw (BadTypeRef cxt n)) . Map.lookup n+lookupTypeRef :: HasCallStack+ => [String] -> Int -> TypeTable -> Type+lookupTypeRef cxt n =+ let explanation = "Bad reference into type table"+ in fromMaybe (X.throw (BadTypeRef callStack cxt explanation n)) . IntMap.lookup n setTypeTable :: TypeTable -> Parse () setTypeTable table = Parse $ do ps <- get- set ps { psTypeTable = table }+ put ps { psTypeTable = table } getTypeTable :: Parse TypeTable getTypeTable = Parse (psTypeTable <$> get)@@ -195,7 +243,7 @@ setTypeTableSize :: Int -> Parse () setTypeTableSize n = Parse $ do ps <- get- set ps { psTypeTableSize = n }+ put ps { psTypeTableSize = n } -- | Retrieve the current type name, failing if it hasn't been set. getTypeName :: Parse Ident@@ -203,17 +251,17 @@ ps <- get str <- case psTypeName ps of Just tn -> do- set ps { psTypeName = Nothing }+ put ps { psTypeName = Nothing } return tn Nothing -> do- set ps { psNextTypeId = psNextTypeId ps + 1 }+ put ps { psNextTypeId = psNextTypeId ps + 1 } return (show (psNextTypeId ps)) return (Ident str) setTypeName :: String -> Parse () setTypeName name = Parse $ do ps <- get- set ps { psTypeName = Just name }+ put ps { psTypeName = Just name } -- | Lookup the value of a type; don't attempt to resolve to an alias. getType' :: Int -> Parse Type@@ -226,9 +274,16 @@ -- | Test to see if the type table has been added to already. isTypeTableEmpty :: Parse Bool-isTypeTableEmpty = Parse (Map.null . psTypeTable <$> get)+isTypeTableEmpty = Parse (IntMap.null . psTypeTable <$> get) +setStringTable :: StringTable -> Parse ()+setStringTable st = Parse $ do+ ps <- get+ put ps { psStringTable = Just st } +getStringTable :: Parse (Maybe StringTable)+getStringTable = Parse (psStringTable <$> get)+ -- Value Tables ---------------------------------------------------------------- -- | Values that have an identifier instead of a string label@@ -238,14 +293,16 @@ data ValueTable = ValueTable { valueNextId :: !Int- , valueEntries :: Map.Map Int (Typed PValue)+ , valueEntries :: IntMap.IntMap (Typed PValue)+ , strtabEntries :: IntMap.IntMap (Int, Int) , valueRelIds :: Bool } deriving (Show) emptyValueTable :: Bool -> ValueTable emptyValueTable rel = ValueTable { valueNextId = 0- , valueEntries = Map.empty+ , valueEntries = IntMap.empty+ , strtabEntries = IntMap.empty , valueRelIds = rel } @@ -257,7 +314,7 @@ where vs' = vs { valueNextId = valueNextId vs + 1- , valueEntries = Map.insert (valueNextId vs) tv (valueEntries vs)+ , valueEntries = IntMap.insert (valueNextId vs) tv (valueEntries vs) } -- | Push a value into the value table, and return its index.@@ -265,7 +322,7 @@ pushValue tv = Parse $ do ps <- get let vt = psValueTable ps- set ps { psValueTable = addValue tv vt }+ put ps { psValueTable = addValue tv vt } return (valueNextId vt) -- | Get the index for the next value.@@ -279,6 +336,8 @@ return (translateValueId vt n) -- | Translate an id, relative to the value table it references.+-- NOTE: The relative conversion has to be done on a Word32 to handle overflow+-- when n is large the same way BitcodeReaderMDValueList::getValue does. translateValueId :: ValueTable -> Int -> Int translateValueId vt n | valueRelIds vt = fromIntegral adjusted | otherwise = n@@ -288,7 +347,7 @@ -- | Lookup an absolute address in the value table. lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)-lookupValueTableAbs n values = Map.lookup n (valueEntries values)+lookupValueTableAbs n values = IntMap.lookup n (valueEntries values) -- | When you know you have an absolute index. lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))@@ -306,9 +365,11 @@ -- | Lookup lazily, hiding an error in the result if the entry doesn't exist by -- the time it's needed. NOTE: This always looks up an absolute index, never a -- relative one.-forwardRef :: [String] -> Int -> ValueTable -> Typed PValue+forwardRef :: HasCallStack+ => [String] -> Int -> ValueTable -> Typed PValue forwardRef cxt n vt =- fromMaybe (X.throw (BadValueRef cxt n)) (lookupValueTableAbs n vt)+ let explanation = "Bad reference into a value table"+ in fromMaybe (X.throw (BadValueRef callStack cxt explanation n)) (lookupValueTableAbs n vt) -- | Require that a value be present. requireValue :: Int -> Parse (Typed PValue)@@ -331,7 +392,7 @@ setValueTable :: ValueTable -> Parse () setValueTable vt = Parse $ do ps <- get- set ps { psValueTable = vt }+ put ps { psValueTable = vt } -- | Update the value table, giving a lazy reference to the final table. fixValueTable :: (ValueTable -> Parse (a,[Typed PValue])) -> Parse a@@ -358,7 +419,7 @@ setMdTable :: MdTable -> Parse () setMdTable md = Parse $ do ps <- get- set $! ps { psMdTable = md }+ put $! ps { psMdTable = md } getMetadata :: Int -> Parse (Typed PValMd) getMetadata ix = do@@ -373,34 +434,36 @@ resolveMd ix ps = nodeRef `mplus` mdValue where reference = Typed (PrimType Metadata) . ValMd . ValMdRef- nodeRef = reference `fmap` Map.lookup ix (psMdRefs ps)- mdValue = Map.lookup ix (valueEntries (psMdTable ps))+ nodeRef = reference `fmap` IntMap.lookup ix (psMdRefs ps)+ mdValue = lookupValueTableAbs ix (psMdTable ps) -type MdRefTable = Map.Map Int Int+type MdRefTable = IntMap.IntMap Int setMdRefs :: MdRefTable -> Parse () setMdRefs refs = Parse $ do ps <- get- set $! ps { psMdRefs = refs `Map.union` psMdRefs ps }+ put $! ps { psMdRefs = refs `IntMap.union` psMdRefs ps } -- Function Prototypes --------------------------------------------------------- data FunProto = FunProto- { protoType :: Type- , protoLinkage :: Maybe Linkage- , protoGC :: Maybe GC- , protoName :: String- , protoIndex :: Int- , protoSect :: Maybe String- } deriving (Show)+ { protoType :: Type+ , protoLinkage :: Maybe Linkage+ , protoVisibility :: Maybe Visibility+ , protoGC :: Maybe GC+ , protoSym :: Symbol+ , protoIndex :: Int+ , protoSect :: Maybe String+ , protoComdat :: Maybe String+ } deriving Show -- | Push a function prototype on to the prototype stack. pushFunProto :: FunProto -> Parse () pushFunProto p = Parse $ do ps <- get- set ps { psFunProtos = psFunProtos ps Seq.|> p }+ put ps { psFunProtos = psFunProtos ps Seq.|> p } -- | Take a single function prototype off of the prototype stack. popFunProto :: Parse FunProto@@ -409,7 +472,7 @@ case Seq.viewl (psFunProtos ps) of Seq.EmptyL -> fail "empty function prototype stack" p Seq.:< ps' -> do- Parse (set ps { psFunProtos = ps' })+ Parse (put ps { psFunProtos = ps' }) return p @@ -443,29 +506,31 @@ , symTypeSymtab :: TypeSymtab } deriving (Show) +instance Semigroup Symtab where+ l <> r = Symtab+ { symValueSymtab = symValueSymtab l <> symValueSymtab r+ , symTypeSymtab = symTypeSymtab l <> symTypeSymtab r+ }+ instance Monoid Symtab where mempty = Symtab { symValueSymtab = emptyValueSymtab , symTypeSymtab = mempty } - mappend l r = Symtab- { symValueSymtab = symValueSymtab l `Map.union` symValueSymtab r- , symTypeSymtab = symTypeSymtab l `mappend` symTypeSymtab r- }+ mappend = (<>) withSymtab :: Symtab -> Parse a -> Parse a withSymtab symtab body = Parse $ do- env <- ask- local (extendSymtab symtab env) (unParse body)+ local (extendSymtab symtab) (unParse body) -- | Run a computation with an extended value symbol table. withValueSymtab :: ValueSymtab -> Parse a -> Parse a withValueSymtab symtab = withSymtab (mempty { symValueSymtab = symtab }) -- | Retrieve the value symbol table.-getValueSymtab :: Parse ValueSymtab-getValueSymtab = Parse (symValueSymtab . envSymtab <$> ask)+getValueSymtab :: Finalize ValueSymtab+getValueSymtab = Finalize (symValueSymtab . envSymtab <$> ask) -- | Run a computation with an extended type symbol table. withTypeSymtab :: TypeSymtab -> Parse a -> Parse a@@ -478,14 +543,13 @@ -- | Label a sub-computation with its context. label :: String -> Parse a -> Parse a label l m = Parse $ do- env <- ask- local (addLabel l env) (unParse m)+ local (addLabel l) (unParse m) -- | Fail, taking into account the current context. failWithContext :: String -> Parse a failWithContext msg = Parse $ do env <- ask- raise Error+ throwError Error { errMessage = msg , errContext = envContext env }@@ -495,7 +559,7 @@ getType :: Int -> Parse Type getType ref = do symtab <- getTypeSymtab- case Map.lookup ref (tsById symtab) of+ case IntMap.lookup ref (tsById symtab) of Just i -> return (Alias i) Nothing -> getType' ref @@ -505,21 +569,35 @@ symtab <- getTypeSymtab case Map.lookup n (tsByName symtab) of Just ix -> return ix- Nothing -> fail ("unknown type alias " ++ show (ppLLVM (ppIdent n)))+ Nothing -> fail ("unknown type alias " ++ show (ppLLVM llvmVlatest (llvmPP n))) -- Value Symbol Table ---------------------------------------------------------- type SymName = Either String Int -type ValueSymtab = Map.Map SymTabEntry SymName+data ValueSymtab =+ ValueSymtab+ { valSymtab :: IntMap.IntMap SymName+ , bbSymtab :: IntMap.IntMap SymName+ , fnSymtab :: IntMap.IntMap SymName+ } deriving (Show) -data SymTabEntry- = SymTabEntry !Int- | SymTabBBEntry !Int- | SymTabFNEntry !Int- deriving (Eq,Ord,Show)+instance Semigroup ValueSymtab where+ l <> r = ValueSymtab+ { valSymtab = valSymtab l `IntMap.union` valSymtab r+ , bbSymtab = bbSymtab l `IntMap.union` bbSymtab r+ , fnSymtab = fnSymtab l `IntMap.union` fnSymtab r+ } +instance Monoid ValueSymtab where+ mappend = (<>)+ mempty = ValueSymtab+ { valSymtab = IntMap.empty+ , bbSymtab = IntMap.empty+ , fnSymtab = IntMap.empty+ }+ renderName :: SymName -> String renderName = either id show @@ -527,72 +605,84 @@ mkBlockLabel = either (Named . Ident) Anon emptyValueSymtab :: ValueSymtab-emptyValueSymtab = Map.empty+emptyValueSymtab = mempty addEntry :: Int -> String -> ValueSymtab -> ValueSymtab-addEntry i n = Map.insert (SymTabEntry i) (Left n)+addEntry i n t = t { valSymtab = IntMap.insert i (Left n) (valSymtab t) } addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab-addBBEntry i n = Map.insert (SymTabBBEntry i) (Left n)+addBBEntry i n t = t { bbSymtab = IntMap.insert i (Left n) (bbSymtab t) } addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab-addBBAnon i n = Map.insert (SymTabBBEntry i) (Right n)+addBBAnon i n t = t { bbSymtab = IntMap.insert i (Right n) (bbSymtab t) } addFNEntry :: Int -> Int -> String -> ValueSymtab -> ValueSymtab -- TODO: do we ever need to be able to look up the offset?-addFNEntry i _o n = Map.insert (SymTabFNEntry i) (Left n)+addFNEntry i _o n t = t { fnSymtab = IntMap.insert i (Left n) (fnSymtab t) } +addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab+addFwdFNEntry i o t = t { fnSymtab = IntMap.insert i (Right o) (fnSymtab t) }++-- | Lookup the name of an entry. Returns @Nothing@ when it's not present.+entryNameMb :: Int -> Parse (Maybe String)+entryNameMb n = do+ symtab <- liftFinalize getValueSymtab+ return $! fmap renderName+ $ IntMap.lookup n (valSymtab symtab) `mplus`+ IntMap.lookup n (fnSymtab symtab)+ -- | Lookup the name of an entry. entryName :: Int -> Parse String entryName n = do- symtab <- getValueSymtab- let mentry = Map.lookup (SymTabEntry n) symtab `mplus`- Map.lookup (SymTabFNEntry n) symtab+ mentry <- entryNameMb n case mentry of- Just i -> return (renderName i)- Nothing ->- do isRel <- getRelIds+ Just name -> return name+ Nothing ->+ do isRel <- getRelIds+ symtab <- liftFinalize getValueSymtab fail $ unlines [ "entry " ++ show n ++ (if isRel then " (relative)" else "") ++ " is missing from the symbol table" , show symtab ] -- | Lookup the name of a basic block.-bbEntryName :: Int -> Parse (Maybe BlockLabel)+bbEntryName :: Int -> Finalize (Maybe BlockLabel) bbEntryName n = do symtab <- getValueSymtab- return (mkBlockLabel <$> Map.lookup (SymTabBBEntry n) symtab)+ return (mkBlockLabel <$> IntMap.lookup n (bbSymtab symtab)) -- | Lookup the name of a basic block.-requireBbEntryName :: Int -> Parse BlockLabel+requireBbEntryName :: Int -> Finalize BlockLabel requireBbEntryName n = do mb <- bbEntryName n case mb of Just l -> return l Nothing -> fail ("basic block " ++ show n ++ " has no id") - -- Type Symbol Tables ---------------------------------------------------------- data TypeSymtab = TypeSymtab- { tsById :: Map.Map Int Ident+ { tsById :: IntMap.IntMap Ident , tsByName :: Map.Map Ident Int } deriving Show +instance Semigroup TypeSymtab where+ l <> r = TypeSymtab+ { tsById = tsById l `IntMap.union` tsById r+ , tsByName = tsByName l `Map.union` tsByName r+ }+ instance Monoid TypeSymtab where mempty = TypeSymtab- { tsById = Map.empty+ { tsById = IntMap.empty , tsByName = Map.empty } - mappend l r = TypeSymtab- { tsById = tsById l `Map.union` tsById r- , tsByName = tsByName l `Map.union` tsByName r- }+ mappend = (<>) addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab addTypeSymbol ix n ts = ts- { tsById = Map.insert ix n (tsById ts)+ { tsById = IntMap.insert ix n (tsById ts) , tsByName = Map.insert n ix (tsByName ts) } @@ -600,12 +690,12 @@ -- Metadata Kind Table --------------------------------------------------------- data KindTable = KindTable- { ktNames :: Map.Map Int String+ { ktNames :: IntMap.IntMap String } deriving (Show) emptyKindTable :: KindTable emptyKindTable = KindTable- { ktNames = Map.fromList+ { ktNames = IntMap.fromList [ (0, "dbg" ) , (1, "tbaa" ) , (2, "prof" )@@ -618,12 +708,83 @@ addKind kind name = Parse $ do ps <- get let KindTable { .. } = psKinds ps- set $! ps { psKinds = KindTable { ktNames = Map.insert kind name ktNames } }+ put $! ps { psKinds = KindTable { ktNames = IntMap.insert kind name ktNames } } getKind :: Int -> Parse String-getKind kind = Parse $ do- ps <- get+getKind kind = do+ ps <- Parse get let KindTable { .. } = psKinds ps- case Map.lookup kind ktNames of+ case IntMap.lookup kind ktNames of Just name -> return name Nothing -> fail ("Unknown kind id: " ++ show kind ++ "\nKind table: " ++ show (psKinds ps))++-- Partial Symbols -------------------------------------------------------------++newtype StringTable = Strtab BS.ByteString+ deriving (Show)+--newtype SymbolTable = Symtab BS.ByteString++mkStrtab :: BS.ByteString -> StringTable+mkStrtab = Strtab++--mkSymtab :: BS.ByteString -> SymbolTable+--mkSymtab = Symtab++resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol+resolveStrtabSymbol (Strtab bs) start len =+ Symbol $ UTF8.decode $ BS.unpack $ BS.take len $ BS.drop start bs++-- Finalize Monad --------------------------------------------------------------++newtype Finalize a = Finalize+ { unFinalize :: ReaderT Env (Except Error) a+ } deriving (Functor, Applicative)++instance Monad Finalize where+#if !MIN_VERSION_base(4,11,0)+ {-# INLINE return #-}+ return = pure+#endif++ {-# INLINE (>>=) #-}+ Finalize m >>= f = Finalize (m >>= unFinalize . f)++#if !MIN_VERSION_base(4,13,0)+ {-# INLINE fail #-}+ fail = failWithContext'+#endif++instance MonadFail Finalize where+ {-# INLINE fail #-}+ fail = failWithContext'++instance Alternative Finalize where+ {-# INLINE empty #-}+ empty = failWithContext' "empty"++ {-# INLINE (<|>) #-}+ a <|> b = Finalize $ catchError (unFinalize a) (const (unFinalize b))++instance MonadPlus Finalize where+ {-# INLINE mzero #-}+ mzero = failWithContext' "mzero"++ {-# INLINE mplus #-}+ mplus = (<|>)++-- | Fail, taking into account the current context.+failWithContext' :: String -> Finalize a+failWithContext' msg =+ Finalize $+ do env <- ask+ throwError Error+ { errMessage = msg+ , errContext = envContext env+ }++liftFinalize :: Finalize a -> Parse a+liftFinalize (Finalize m) =+ do env <- Parse ask+ case runExcept (runReaderT m env) of+ Left err -> Parse (throwError err)+ Right a -> return a
src/Data/LLVM/BitCode/Record.hs view
@@ -1,17 +1,19 @@+{-# LANGUAGE MultiWayIf #-} module Data.LLVM.BitCode.Record where import Data.LLVM.BitCode.Bitstream import Data.LLVM.BitCode.BitString hiding (drop,take) import Data.LLVM.BitCode.Match import Data.LLVM.BitCode.Parse+import Text.LLVM.AST import Data.Bits (Bits,testBit,shiftR,bit)-import Data.Char (chr) import Data.Int (Int64)-import Data.Word (Word64)+import Data.Word (Word8,Word32,Word64) import Data.ByteString (ByteString) -import Control.Monad ((<=<),MonadPlus(..),guard)+import qualified Codec.Binary.UTF8.String as UTF8 (decode)+import Control.Monad ((<=<),MonadPlus(..)) -- Generic Records -------------------------------------------------------------@@ -34,8 +36,9 @@ -- | Record construction from an abbreviated field. fromAbbrev :: Match AbbrevRecord Record fromAbbrev a = do- guard (not (null (abbrevFields a)))- let (f:fs) = abbrevFields a+ -- If abbrevFields is empty here, it will cause the Match to fail with+ -- Nothing, at which point alternatives may then be tried.+ (f:fs) <- return $ abbrevFields a code <- numeric f return Record { recordCode = code@@ -67,7 +70,7 @@ fieldVbr _ = mzero -- | Match a character field.-fieldChar6 :: Match Field Char+fieldChar6 :: Match Field Word8 fieldChar6 (FieldChar6 c) = return c fieldChar6 _ = mzero @@ -114,7 +117,7 @@ loop [] = return [] -- | Parse a @Field@ as a numeric value.-numeric :: Num a => Match Field a+numeric :: (Num a, Bits a) => Match Field a numeric = fmap fromBitString . (fieldLiteral ||| fieldFixed ||| fieldVbr) signedImpl :: (Bits a, Num a) => Match Field a@@ -135,26 +138,49 @@ signedInt64 :: Match Field Int64 signedInt64 = signedImpl +-- | Parse a @Field@ as a Word32.+unsigned :: Match Field Word32+unsigned = numeric+ boolean :: Match Field Bool boolean = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr) where- decode bs- | bsData bs == 1 = return True- | bsData bs == 0 = return False- | otherwise = mzero+ decode bs = case bitStringValue bs of+ 0 -> return False+ 1 -> return True+ _ -> mzero nonzero :: Match Field Bool nonzero = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr) where- decode bs- | bsData bs == 0 = return False- | otherwise = return True+ decode bs = return $ case bitStringValue bs of+ 0 -> False+ _ -> True -char :: Match Field Char-char = fmap chr . numeric+char :: Match Field Word8+char = numeric string :: Match Field String-string = fieldArray char+string = fmap UTF8.decode . fieldArray char cstring :: Match Field String-cstring = fieldArray (fieldChar6 ||| char)+cstring = fmap UTF8.decode . fieldArray (fieldChar6 ||| char)++-- | Lookup the name at the given field index if using an old bitcode+-- version, or in the string table if using a new bitcode version.+-- Returns the name and the offset into the record to use for further+-- queries.+oldOrStrtabName :: Int -> Record -> Parse (Symbol, Int)+oldOrStrtabName n r = do+ v <- getModVersion+ if | v < 2 -> do+ name <- entryName n+ return (Symbol name, 0)+ | otherwise -> do+ mst <- getStringTable+ case mst of+ Just st -> do+ offset <- parseField r 0 numeric+ len <- parseField r 1 numeric+ return (resolveStrtabSymbol st offset len, 2)+ Nothing -> fail "New-style name encountered with no string table."
src/Data/LLVM/CFG.hs view
@@ -29,10 +29,10 @@ import Control.Arrow +import Data.Functor.Identity (runIdentity) import qualified Data.Graph.Inductive.Query.Dominators as Dom import qualified Data.Graph.Inductive as G import qualified Data.Map as M-import MonadLib (runId) import Text.LLVM hiding (BB) import qualified Text.LLVM.Labels as L@@ -171,7 +171,7 @@ nodeByName = fmap (\(BBId n, _) -> n) bbIds - fixLabels stmts = runId (mapM (L.relabel f) stmts)+ fixLabels stmts = runIdentity (mapM (L.relabel f) stmts) where -- This should be fine, as there shouldn't be references to labels that -- aren't defined.
+ src/Data/LLVM/Internal.hs view
@@ -0,0 +1,6 @@+-- | This module exports some internal modules *for use in testing only*.+module Data.LLVM.Internal+ ( module Data.LLVM.BitCode.IR.Metadata+ ) where++import Data.LLVM.BitCode.IR.Metadata
+ unit-test/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified Test.Tasty as T+import qualified Tests.Metadata++main :: IO ()+main = T.defaultMain $ T.testGroup "Tests" [ Tests.Metadata.tests+ ]
+ unit-test/Tests/ExpressionInstances.hs view
@@ -0,0 +1,43 @@+module Tests.ExpressionInstances where++import Generic.Random hiding ((%))+import Test.QuickCheck.Arbitrary (Arbitrary(..))++import Text.LLVM.AST++import Tests.PrimInstances ()+++instance Arbitrary lab => Arbitrary (Type' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (Typed lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (ValMd' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (Value' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary ArithOp where arbitrary = genericArbitrary uniform+instance Arbitrary UnaryArithOp where arbitrary = genericArbitrary uniform+instance Arbitrary BitOp where arbitrary = genericArbitrary uniform+instance Arbitrary ConvOp where arbitrary = genericArbitrary uniform+instance Arbitrary ICmpOp where arbitrary = genericArbitrary uniform+instance Arbitrary FCmpOp where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DebugLoc' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (ConstExpr' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DebugInfo' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DIImportedEntity' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DITemplateTypeParameter' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DITemplateValueParameter' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DINameSpace' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary DIBasicType where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (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 DIExpression where arbitrary = genericArbitrary uniform+instance Arbitrary DIFile where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DIGlobalVariable' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DIGlobalVariableExpression' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DILexicalBlock' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DILexicalBlockFile' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DILocalVariable' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DISubprogram' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DISubrange' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DISubroutineType' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DILabel' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DIArgList' lab) where arbitrary = genericArbitrary uniform
+ unit-test/Tests/FuncDataInstances.hs view
@@ -0,0 +1,24 @@+module Tests.FuncDataInstances where++import Generic.Random hiding ((%))+import Test.QuickCheck.Arbitrary (Arbitrary(..))++import Text.LLVM.AST++import Tests.StmtInstances ()+++instance Arbitrary BlockLabel where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (BasicBlock' lab) where+ arbitrary = genericArbitrary uniform++instance Arbitrary TypeDecl where arbitrary = genericArbitrary uniform+instance Arbitrary Global where arbitrary = genericArbitrary uniform+instance Arbitrary GlobalAttrs where arbitrary = genericArbitrary uniform+instance Arbitrary Linkage where arbitrary = genericArbitrary uniform+instance Arbitrary Visibility where arbitrary = genericArbitrary uniform++instance Arbitrary FunAttr where arbitrary = genericArbitrary uniform+instance Arbitrary Define where arbitrary = genericArbitrary uniform+instance Arbitrary Declare where arbitrary = genericArbitrary uniform+instance Arbitrary GC where arbitrary = genericArbitrary uniform
+ unit-test/Tests/Instances.hs view
@@ -0,0 +1,39 @@+-- | Arbitrary instances for LLVM AST nodes, for QuickCheck.+--+-- These declarations are actually spread across a number of files. This spread+-- must allow for dependencies between instances, which would not be as much of+-- an issue if they were all collected in a single file, but the single file+-- takes much more time and memory to compile.+--+-- In one file: 2m13s compilation, ~10GB RAM+-- top + triple + prim + expr + stmt + funcdata: 32s compilation, ~ 1GB RAM++module Tests.Instances where++import Generic.Random hiding ((%))+import Test.QuickCheck.Arbitrary (Arbitrary(..))++import Data.LLVM.Internal+import Text.LLVM.AST++import Tests.TripleInstances ()+import Tests.FuncDataInstances ()+import Tests.ExpressionInstances ()+import Tests.StmtInstances ()++-------------------------------------------------------------------------+-- ** llvm-pretty++instance Arbitrary Module where arbitrary = genericArbitrary uniform+instance Arbitrary NamedMd where arbitrary = genericArbitrary uniform+instance Arbitrary UnnamedMd where arbitrary = genericArbitrary uniform+instance Arbitrary GlobalAlias where arbitrary = genericArbitrary uniform+instance Arbitrary LayoutSpec where arbitrary = genericArbitrary uniform+instance Arbitrary Mangling where arbitrary = genericArbitrary uniform+instance Arbitrary SelectionKind where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (NullResult lab) where arbitrary = genericArbitrary uniform++-------------------------------------------------------------------------+-- ** llvm-pretty-bc-parser++instance Arbitrary PartialUnnamedMd where arbitrary = genericArbitrary uniform
+ unit-test/Tests/Metadata.hs view
@@ -0,0 +1,46 @@+module Tests.Metadata (tests) where++import qualified Data.Sequence as Seq+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Data.LLVM.Internal+import Text.LLVM.AST++import Tests.Instances ()+++tests :: TestTree+tests = testGroup "Metadata"+ [ testCase "test dedup metadata" $+ mempty @?= dedupMetadata mempty++ -- The first two should remain unchanged, but the third duplicates information in+ -- the second, so should be updated to hold a reference to it.+ , testGroup "test dedup metadata" $+ let mkPum i v = PartialUnnamedMd i v True+ val1 = mkPum 1 (ValMdString "str")+ val2 = mkPum 2 (ValMdDebugInfo (DebugInfoExpression (DIExpression [])))+ val3 = mkPum 3 (ValMdNode [Just (pumValues val2)])+ deduped = dedupMetadata (Seq.fromList [val1, val2, val3])+ in [ testCase "1" $+ Just val1 @?= deduped Seq.!? 0+ , testCase "2" $+ Just val2 @?= deduped Seq.!? 1+ , testCase "3" $+ Just (mkPum 3 (ValMdNode [Just (ValMdRef 2)])) @?=+ deduped Seq.!? 2+ ]++ -- Deduplication should not changes: references or strings+ -- This test takes too long.+ -- , testProperty "dedup metadata" $+ -- \lst i -> i >= 0 && length lst > i ==>+ -- let result = dedupMetadata lst+ -- in if lst !! i /= result !! i+ -- then case pumValues (result !! i) of+ -- ValMdRef _ -> False+ -- ValMdString _ -> False+ -- _ -> True+ -- else True+ ]
+ unit-test/Tests/PrimInstances.hs view
@@ -0,0 +1,13 @@+module Tests.PrimInstances where++import Generic.Random hiding ((%))+import Test.QuickCheck.Arbitrary (Arbitrary(..))++import Text.LLVM.AST+++instance Arbitrary PrimType where arbitrary = genericArbitrary uniform+instance Arbitrary FloatType where arbitrary = genericArbitrary uniform+instance Arbitrary FP80Value where arbitrary = genericArbitrary uniform+instance Arbitrary Ident where arbitrary = genericArbitrary uniform+instance Arbitrary Symbol where arbitrary = genericArbitrary uniform
+ unit-test/Tests/StmtInstances.hs view
@@ -0,0 +1,15 @@+module Tests.StmtInstances where++import Generic.Random hiding ((%))+import Test.QuickCheck.Arbitrary (Arbitrary(..))++import Text.LLVM.AST++import Tests.ExpressionInstances ()+++instance Arbitrary AtomicRWOp where arbitrary = genericArbitrary uniform+instance Arbitrary AtomicOrdering where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (Instr' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (Clause' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (Stmt' lab) where arbitrary = genericArbitrary uniform
+ unit-test/Tests/TripleInstances.hs view
@@ -0,0 +1,15 @@+module Tests.TripleInstances where++import Generic.Random hiding ((%))+import Test.QuickCheck.Arbitrary (Arbitrary(..))++import qualified Text.LLVM.Triple.AST as Triple+++instance Arbitrary Triple.Arch where arbitrary = genericArbitrary uniform+instance Arbitrary Triple.Environment where arbitrary = genericArbitrary uniform+instance Arbitrary Triple.OS where arbitrary = genericArbitrary uniform+instance Arbitrary Triple.ObjectFormat where arbitrary = genericArbitrary uniform+instance Arbitrary Triple.SubArch where arbitrary = genericArbitrary uniform+instance Arbitrary Triple.TargetTriple where arbitrary = genericArbitrary uniform+instance Arbitrary Triple.Vendor where arbitrary = genericArbitrary uniform