packages feed

llvm-pretty-bc-parser 0.3.0.0 → 0.3.0.1

raw patch · 14 files changed

+1325/−285 lines, 14 filesdep +abstract-pardep +deepseqdep +monad-pardep ~bytestringdep ~containersdep ~llvm-prettynew-component:exe:fuzz-llvm-disasmnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: abstract-par, deepseq, monad-par, random, temporary, time, transformers, xml

Dependency ranges changed: bytestring, containers, llvm-pretty

API changes (from Hackage documentation)

Files

+ fuzzing/Main.hs view
@@ -0,0 +1,551 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Main where++import Control.DeepSeq (($!!), NFData)+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+import Data.Maybe (fromMaybe)+import Data.Monoid (mconcat, Endo(..))+import Data.Time+  (defaultTimeLocale, formatTime, getZonedTime, iso8601DateFormat)+import Data.Typeable (Typeable)+import Data.Word (Word64)+import GHC.Generics (Generic)+import System.Console.GetOpt+  (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo)+import System.Directory+  (copyFile, createDirectoryIfMissing, findExecutable, getFileSize,+   getPermissions, setPermissions, setOwnerExecutable)+import System.Environment (getArgs, getProgName, lookupEnv)+import System.Exit (ExitCode(..), exitFailure, exitSuccess)+import System.FilePath ((</>), (<.>), dropExtension)+import System.IO.Temp (withTempDirectory)+import System.Process+  (callProcess, readProcess, readProcessWithExitCode,+   spawnProcess, waitForProcess)+import System.Random (randomIO)+import Text.Read (readMaybe)+import Text.XML.Light (Attr(..), Element, ppTopElement, unode, unqual)++-- Option Parsing --------------------------------------------------------------++-- | The @clang@ executable and flags for a particular test+-- configuration, e.g., @("clang-3.8", "-O -w -g")@+type Clang = (FilePath, String)++data Options = Options {+    optNumTests :: Integer+    -- ^ Number of Tests+  , optSeeds :: Maybe [Word64]+    -- ^ Specific seeds to use in fuzzing; overrides 'optNumTests'+  , optSaveTests :: Maybe FilePath+    -- ^ Location to save failed tests+  , optClangs :: [FilePath]+    -- ^ Clangs to use with the fuzzer+  , optClangFlags :: [String]+    -- ^ Sets of argument flags to use with each clang configuration+  , optJUnitXml :: Maybe FilePath+    -- ^ Write JUnit test report+  , optCsmithPath :: Maybe FilePath+    -- ^ Path to Csmith include files+  , optCollapse :: Bool+    -- ^ Whether to collapse failures with the same error message+  , optReduceDisasm :: Bool+    -- ^ Whether to try reducing failures at the disasm stage+  , optReduceAs :: Bool+    -- ^ Whether to try reducing failures at the assembly stage+  , optReduceExec :: Bool+    -- ^ Whether to try reducing failures at the execution stage+  , optHelp :: Bool+  } deriving (Show)++defaultOptions :: Options+defaultOptions  = Options {+    optNumTests     = 100+  , optSeeds        = Nothing+  , optSaveTests    = Nothing+  , optClangs       = ["clang"]+  , optClangFlags   = ["-O -g -w"]+  , optJUnitXml     = Nothing+  , optCsmithPath   = Nothing+  , optCollapse     = False+  , optReduceDisasm = False+  , optReduceAs     = False+  , optReduceExec   = False+  , optHelp         = False+  }++options :: [OptDescr (Endo Options)]+options  =+  [ Option "n" [] (ReqArg setNumTests "NUMBER")+    "number of tests to run; default is 100"+  , Option "s" ["seed"] (ReqArg addSeed "SEED")+    "specific Csmith seed to use; overrides -n"+  , Option "o" ["output"] (ReqArg setSaveTests "DIRECTORY")+    "directory to save failed tests"+  , Option "c" ["clang"] (ReqArg addClang "CLANG")+    "specify clang executables to use, e.g., `-c clang-3.8 -c clang-3.9'"+  , Option ""  ["clang-flags"] (ReqArg addClangFlags "ARGS") $+    "specify a set of flags to use with each clang " +++    "e.g., `--clang-flags \"-O\" --clang-flags \"-O -g\"'"+  , Option ""  ["junit-xml"] (ReqArg setJUnitXml "FILEPATH")+    "output JUnit-style XML test report"+  , Option ""  ["csmith-path"] (ReqArg setCsmithPath "DIRECTORY")+    "path to Csmith include files; default is $CSMITH_PATH environment variable"+  , Option ""  ["collapse"] (NoArg setCollapse)+    "collapse failing test cases by error message and remove successes"+  , Option ""  ["reduce-disasm"] (NoArg setReduceDisasm) $+    "reduce test cases that fail disassembly with a best-guess Creduce " +++    "(requires `--output`)"+  , Option ""  ["reduce-as"] (NoArg setReduceAs) $+    "reduce test cases that fail reassembly with a best-guess Creduce " +++    "(requires `--output`)"+  , Option ""  ["reduce-exec"] (NoArg setReduceExec) $+    "reduce test cases that fail on test program execution with a " +++    "best-guess Creduce (requires `--output`)"+  , Option "h" ["help"] (NoArg setHelp)+    "display this message"+  ]++setNumTests :: String -> Endo Options+setNumTests str = Endo $ \opt ->+  case readMaybe str of+    Nothing -> error "expected integer number of tests"+    Just n -> opt { optNumTests = n }++addSeed :: String -> Endo Options+addSeed str = Endo $ \opt ->+  case readMaybe str of+    Nothing -> error "expected 64-bit integer seed"+    Just n ->+      case optSeeds opt of+        Nothing    -> opt { optSeeds = Just [n] }+        Just seeds -> opt { optSeeds = Just (n : seeds) }++setSaveTests :: String -> Endo Options+setSaveTests str = Endo (\opt -> opt { optSaveTests = Just str })++addClang :: String -> Endo Options+addClang str = Endo $ \opt ->+  if optClangs opt == optClangs defaultOptions+  then opt { optClangs = [str] }+  else opt { optClangs = str : optClangs opt }++addClangFlags :: String -> Endo Options+addClangFlags str = Endo $ \opt ->+  if optClangFlags opt == optClangFlags defaultOptions+  then opt { optClangFlags = [str] }+  else opt { optClangFlags = str : optClangFlags opt }++setJUnitXml :: String -> Endo Options+setJUnitXml str = Endo (\opt -> opt { optJUnitXml = Just str })++setCsmithPath :: String -> Endo Options+setCsmithPath str = Endo (\opt -> opt { optCsmithPath = Just str })++setCollapse :: Endo Options+setCollapse = Endo (\opt -> opt { optCollapse = True })++setReduceDisasm :: Endo Options+setReduceDisasm = Endo (\opt -> opt { optReduceDisasm = True })++setReduceAs :: Endo Options+setReduceAs = Endo (\opt -> opt { optReduceAs = True })++setReduceExec :: Endo Options+setReduceExec = Endo (\opt -> opt { optReduceExec = True })++setHelp :: Endo Options+setHelp = Endo (\opt -> opt { optHelp = True })++getOptions :: IO Options+getOptions =+  do args <- getArgs+     case getOpt RequireOrder options args of++       (fs,[],[]) -> do let opts = appEndo (mconcat fs) defaultOptions++                        when (optHelp opts) $ do printUsage []+                                                 exitSuccess++                        return opts++       (_,_,errs) -> do printUsage errs+                        exitFailure++printUsage :: [String] -> IO ()+printUsage errs =+  do prog <- getProgName+     let banner = "Usage: " ++ prog ++ " [OPTIONS]"+     putStrLn (usageInfo (unlines (errs ++ [banner])) options)++main :: IO ()+main = withTempDirectory "." ".fuzz." $ \tmpDir -> do+  opts <- getOptions+  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+  resultMaps <-+    forM (optClangs opts) $ \clangExe ->+    forM (optClangFlags opts) $ \flags -> runParIO $ do+      let clang = (clangExe, flags)+      liftIO $ putStrLn $ "[" ++ clangExe ++ " " ++ flags ++ "]"+      results' <-+        case optSeeds opts of+          Nothing ->+            forM [1..optNumTests opts] $ \_ ->+              spawn $ liftIO $ 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+    let (_passes, fails) = partition isPass results+    when (not (null fails)) $ do+      putStrLn $ "[" ++ clangExe ++ " " ++ flags ++ "] " +++        show (length fails) ++ " failing cases identified:"+      forM_ fails $ \case+        TestFail st s _ _ -> putStrLn ("[" ++ show st ++ "] " ++ show s)+        _ -> error "non-fail cases in fails"+  case optSaveTests opts of+    Nothing -> return ()+    Just root -> do+      createDirectoryIfMissing False root+      forM_ (Map.toList allResults) $ \((clangExe, flags), results) ->+        when (not (null (filter isFail results))) $ do+          let clangRoot = root </> (clangExe ++ "_" ++ toUnders " " flags)+          createDirectoryIfMissing False clangRoot+          forM_ results $ \result ->+            case result of+              TestPass _ -> return ()+              -- errors arise from bugs in clang, not our code+              TestClangError _ -> return ()+              -- if the initial Csmith program doesn't terminate, don't bother+              TestExecTimeout _ -> return ()+              TestFail st _ TestSrc{..} err -> do+                copyFile (tmpDir </> srcFile) (clangRoot </> srcFile)+                writeFile (clangRoot </> srcFile <.> show st <.> "err") err+                when (or [ st == DisasmStage && optReduceDisasm opts+                         , st == AsStage     && optReduceAs opts+                         , st == ExecStage   && optReduceExec opts ]) $+                  reduce result (clangExe, flags) opts clangRoot+  case optJUnitXml opts of+    Nothing -> return ()+    Just f -> do+      xml <- mkJUnitXml allResults+      writeFile f (ppTopElement xml)++reduce :: TestResult -> Clang -> Options -> FilePath -> IO ()+reduce (TestFail st _ TestSrc{..} err) (clangExe, 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 =+        case stripPrefix "clang-" clangExe of+          Nothing -> ""+          Just ver -> "--llvm-version=" ++ ver+  copyFile (clangRoot </> srcFile) srcReduced+  let grepPat DisasmStage =+        -- look for the first line of the error starting with a+        -- tab; this should be the top of the llvm-disasm stack+        -- trace+        case dropWhile (not . isPrefixOf "\t") (lines err) of+          -- if we don't have a stack trace, we probably shouldn't+          -- waste our time+          [] -> Nothing+          -- drop the tab for the pattern+          first:_ -> Just (tail first)+      grepPat AsStage =+        -- check the first line of the clang error for "error:"+        case (lines err) of+          [] -> Nothing+          first:_ ->+            case dropWhile (/= "error:") (words first) of+              [] -> Nothing+              msg -> Just (unwords msg)+      grepPat ExecStage = error "no grep pattern for exec reduction"+      scriptHeader = [+          "#!/usr/bin/env bash"+        , "# Consider this script a best guess template for reducing failing"+        , "# test cases. Not every bug will manifest in the same way and give"+        , "# the same error message, so modify the grep condition appropriately"+        , "# if the shrink is unsatisfactory."+        , ""+        , "set -e"+        , ""+        ]+      buildBc = unwords [+          clangExe, "-I", csmithPath, flags, "-c"+        , "-emit-llvm", baseName ++ "-reduced.c", "-o", baseName <.> "bc"+        ]+      buildLl = unwords [+          "llvm-disasm", llvmVersion, baseName <.> "bc", ">", baseName <.> "ll"+        ]+      script DisasmStage = unlines $ scriptHeader ++ [+          buildBc+        , unwords [ "llvm-disasm", llvmVersion, baseName <.> "bc", "2>&1 |"+                  , "grep", show (fromMaybe "" (grepPat st))+                  ]+        ]+      script AsStage = unlines $ scriptHeader ++ [+          buildBc+        , buildLl+        , unwords [ clangExe, "-I", csmithPath, flags, "-c"+                  , baseName <.> "ll", "-o", baseName <.> "o", "2>&1 |"+                  , "fgrep ", show (fromMaybe "" (grepPat st))+                  ]+        ]+      script ExecStage = unlines $ scriptHeader ++ [+          buildBc+        , buildLl+        , unwords [ clangExe, "-I", csmithPath, flags+                  , baseName <.> "bc", "-o", "golden"+                  ]+        , unwords [ clangExe, "-I", csmithPath, flags+                  , baseName <.> "ll", "-o", "ours"+                  ]+        , "GOLDEN=$(timeout 10 ./golden)"+        , "[ \"$GOLDEN\" != \"$(./ours)\" ]"+        ]+  when (grepPat st /= Nothing) $ do+    -- write out the shell script to drive Creduce and run it+    writeFile scriptFile (script st)+    p <- getPermissions scriptFile+    setPermissions scriptFile (setOwnerExecutable True p)+    h <- spawnProcess "creduce" [ scriptFile, srcReduced ]+    void $ waitForProcess h++reduce _ _ _ _ = error "can't reduce non-failing test"++collapseResults :: Map Clang [TestResult] -> Map Clang [TestResult]+collapseResults = Map.map (collapse Map.empty)+  where+    collapse seen [] = Map.elems seen+    collapse seen (r:results) =+      case r of+        TestPass _ -> collapse seen results+        -- errors arise from bugs in clang, not our code+        TestClangError _ -> collapse seen results+        TestExecTimeout _ -> collapse seen results+        TestFail st _ _ err ->+          collapse (Map.insertWith f (st, err) r seen) results+    -- choose the smallest source file+    f r1@(TestFail _ _ src1 _) r2@(TestFail _ _ src2 _) =+      case compare (srcSize src1) (srcSize src2) of+        LT -> r1+        EQ -> r1 -- arbitrarily+        GT -> r2+    f _ _ = error "only test failures should go in this map"++type Seed = Word64++data TestResult+  = TestPass Seed+  | TestFail TestStage Seed TestSrc String+  | TestClangError Seed+  -- ^ For now, errors are treated the same as passes, since we're not+  -- concerned with clang bugs+  | TestExecTimeout Seed+  -- ^ If the Csmith-generated program fails to terminate quickly+  deriving (Eq, Show, Generic, NFData, Typeable)++instance X.Exception TestResult++data TestStage+  = DisasmStage+  | AsStage+  | ExecStage+  deriving (Eq, Ord, Show, Generic, NFData)++data TestSrc = TestSrc { srcFile :: FilePath, srcSize :: Integer }+  deriving (Eq, Show, Generic, NFData)++isPass :: TestResult -> Bool+isPass (TestPass _) = True+isPass _            = False++isFail :: TestResult -> Bool+isFail = not . isPass++runTest :: FilePath -> Clang -> Seed -> Options -> IO TestResult+runTest tmpDir (clangExe, flags) seed opts = X.handle return $ do+  let baseFile = show seed+      srcFile  = baseFile <.> "c"+      bcFile   = baseFile <.> "bc"+      llFile   = baseFile <.> "ll"+      llvmVersion =+        case stripPrefix "clang-" clangExe of+          Nothing -> ""+          Just ver -> "--llvm-version=" ++ ver+  csmithPath <- getCsmithPath opts+  callProcess "csmith" [+      "-o", tmpDir </> srcFile+    , "-s", show seed+    ]+  srcSize <- getFileSize (tmpDir </> srcFile)+  h <- spawnProcess clangExe (words flags ++ [+      "-I" ++ csmithPath+    , "-c", "-emit-llvm"+    , tmpDir </> srcFile+    , "-o", tmpDir </> bcFile+    ])+  clangErr <- waitForProcess h+  unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed+  (ec, out, err) <-+    readProcessWithExitCode "llvm-disasm" [ llvmVersion, tmpDir </> bcFile ] ""+  case ec of+    ExitFailure c -> do+      putStrLn "[DISASM ERROR]"+      putStrLn "[OUT]"+      putStr out+      putStrLn "[ERR]"+      putStr err+      putStrLn ("[ERROR CODE " ++ show c ++ "]")+      X.throw $!! TestFail DisasmStage seed TestSrc{..} err+    ExitSuccess -> return ()+  writeFile (tmpDir </> llFile) out+  (ec, out, err) <- readProcessWithExitCode clangExe (words flags ++ [+      "-I" ++ csmithPath+    , tmpDir </> llFile+    , "-o", tmpDir </> "ours"+    ]) ""+  case ec of+    ExitFailure c -> do+      putStrLn "[AS ERROR]"+      putStrLn "[OUT]"+      putStr out+      putStrLn "[ERR]"+      putStr err+      putStrLn ("[ERROR CODE " ++ show c ++ "]")+      X.throw $!! TestFail AsStage seed TestSrc{..} err+    ExitSuccess -> return ()+  h <- spawnProcess clangExe (words flags ++ [+      "-I" ++ csmithPath+    , tmpDir </> bcFile+    , "-o", tmpDir </> "golden"+    ])+  clangErr <- waitForProcess h+  unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed+  timeout <- getTimeoutCmd+  (ec1, out1, err1) <- do+    readProcessWithExitCode timeout [ "10", (tmpDir </> "golden") ] ""+  unless (ec1 == ExitFailure 124) $ X.throw $!! TestExecTimeout seed+  (ec2, out2, err2) <-+    readProcessWithExitCode timeout [ "10", (tmpDir </> "ours") ] ""+  when (ec1 /= ec2 || out1 /= out2 || err1 /= err2) $+    X.throw $!! TestFail ExecStage seed TestSrc{..} err2+  putStrLn "[PASS]"+  return (TestPass seed)++getCsmithPath :: Options -> IO FilePath+getCsmithPath opts =+  case optCsmithPath opts of+    Just p -> return p+    Nothing -> do+      mp <- lookupEnv "CSMITH_PATH"+      case mp of+        Just p -> return p+        Nothing -> error "--csmith-path not given and CSMITH_PATH not set"++getTimeoutCmd :: IO FilePath+getTimeoutCmd = do+  mf <- findExecutable "timeout"+  case mf of+    Just timeout -> return timeout+    Nothing -> do+      mf <- findExecutable "gtimeout"+      case mf of+        Just timeout -> return timeout+        Nothing -> error "could not find `timeout' or `gtimeout' in PATH"++mkJUnitXml :: Map Clang [TestResult] -> IO Element+mkJUnitXml allResults = do+  hostname <- readProcess "hostname" [] ""+  now <- getZonedTime+  let nowFmt = formatTime+                 defaultTimeLocale+                 (iso8601DateFormat (Just "%H:%M:%S"))+                 now+      testsuites = map (testsuite hostname nowFmt) (Map.toList allResults)+  return $ unode "testsuites" testsuites+  where+    fmtClang (clangExe, flags) = toUnders ". " (clangExe ++ "_" ++ flags)+    testsuite hostname nowFmt (clang, results) =+      unode "testsuite" ([+          uattr "name"      "llvm-disasm fuzzer"+        , uattr "tests"     (show (length results))+        , uattr "failures"  (show (length (filter isFail results)))+        , uattr "errors"    "0"+        , uattr "skipped"   "0"+        , uattr "timestamp" nowFmt+        , uattr "time"      "0.0" -- irrelevant due to random input+        , uattr "id"        ""+        , uattr "package"   (fmtClang clang)+        , uattr "hostname"  hostname+        ]+        , flip map results $ \res ->+            case res of+              TestPass seed ->+                unode "testcase" [+                    uattr "name"      (show seed)+                  , uattr "classname" (fmtClang clang)+                  , uattr "time"      "0.0"+                  ]+              TestClangError seed ->+                unode "testcase" ([+                    uattr "name"      (show seed)+                  , uattr "classname" (fmtClang clang)+                  , uattr "time"      "0.0"+                  ]+                  , "clang error"+                  )+              TestExecTimeout seed ->+                unode "testcase" ([+                    uattr "name"      (show seed)+                  , uattr "classname" (fmtClang clang)+                  , uattr "time"      "0.0"+                  ]+                  , "Csmith-generated program did not terminate quickly"+                  )+              TestFail st seed _ err ->+                unode "testcase" ([+                    uattr "name"      (show seed ++ "_" ++ show st)+                  , uattr "classname" (fmtClang clang)+                  , uattr "time"      "0.0"+                  ]+                  , unode "failure" ([+                        uattr "message" ""+                      , uattr "type"    ""+                      ]+                      , err+                      )+                  )+        )++uattr :: String -> String -> Attr+uattr k v = Attr (unqual k) v++toUnders :: String -> String -> String+toUnders cs = map (\c -> if c `elem` cs then '_' else c)
llvm-disasm/LLVMDis.hs view
@@ -1,33 +1,79 @@-+{-# 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 (ppLLVM, ppModule)+import Text.LLVM.PP (ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, ppModule)+import Text.PrettyPrint (Style(..), renderStyle, style)  import Control.Monad (when) import Data.Graph.Inductive.Graph (nmap, emap) import Data.Graph.Inductive.Dot (fglToDotString, showDot)-import Data.List (partition)+import Data.Monoid (mconcat, Endo(..))+import System.Console.GetOpt+  (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo) import System.Environment (getArgs,getProgName)-import System.Exit (exitFailure)+import System.Exit (exitFailure, exitSuccess) import System.IO (stderr,hPutStrLn) import qualified Data.ByteString as S +data Options = Options {+    optLLVMVersion :: String+  , optDoCFG       :: Bool+  , optHelp        :: Bool+  } deriving (Show)++defaultOptions :: Options+defaultOptions  = Options {+    optLLVMVersion = "3.8"+  , optDoCFG       = 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)"+  , Option "" ["cfg"] (NoArg setDoCFG)+    "output CFG in graphviz format"+  , Option "h" ["help"] (NoArg setHelp)+    "display this message"+  ]++getOptions :: IO (Options, [FilePath])+getOptions =+  do args <- getArgs+     case getOpt RequireOrder options args of+       (fs,files@(_:_),[]) -> do+         let opts = appEndo (mconcat fs) defaultOptions+         when (optHelp opts) $+           printUsage [] >> exitSuccess+         return (opts,files)+       (_,_,errs) -> do printUsage errs+                        exitFailure++printUsage :: [String] -> IO ()+printUsage errs =+  do prog <- getProgName+     let banner = "Usage: " ++ prog ++ " [OPTIONS]"+     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 })++setHelp :: Endo Options+setHelp = Endo (\opt -> opt { optHelp = True })+ main :: IO () main  = do-  args <- getArgs-  let (doCFG, files) = partition (== "-cfg") args-  when (null files) (printUsage >> exitFailure)-  mapM_ (disasm (not $ null doCFG)) files--printUsage :: IO ()-printUsage  = do-  name <- getProgName-  putStrLn ("Usage: " ++ name ++ " [-cfg] { file.bc }+")+  (opts, files) <- getOptions+  mapM_ (disasm opts) files -disasm :: Bool -> FilePath -> IO ()-disasm doCFG file = do-  putStrLn (replicate 80 '=' ++ "\n")+disasm :: Options -> [Char] -> IO ()+disasm opts file = do+  putStrLn (replicate 80 ';' ++ "\n")   putStrLn ("; " ++ file)   e <- parseBitCode =<< S.readFile file   case e of@@ -37,8 +83,20 @@       exitFailure      Right m  -> do-      print (ppLLVM (ppModule m))-      when doCFG $ 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
llvm-pretty-bc-parser.cabal view
@@ -1,5 +1,5 @@ Name:                llvm-pretty-bc-parser-Version:             0.3.0.0+Version:             0.3.0.1 License:             BSD3 License-file:        LICENSE Author:              Trevor Elliott <trevor@galois.com>@@ -15,6 +15,10 @@  Extra-source-files:  disasm-test/tests/*.ll +Flag fuzz+  Description:         Enable fuzzing harness+  Default:             False+ Source-repository head   type:                git   location:            http://github.com/galoisinc/llvm-pretty-bc-parser@@ -53,7 +57,7 @@                        fgl        >= 5.5,                        cereal     >= 0.3.5.2,                        bytestring >= 0.9.1,-                       llvm-pretty>= 0.5+                       llvm-pretty>= 0.6  Executable llvm-disasm   Main-is:             LLVMDis.hs@@ -85,3 +89,29 @@                        filepath,                        llvm-pretty>= 0.5,                        llvm-pretty-bc-parser++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,+                       process,+                       directory,+                       bytestring,+                       filepath,+                       temporary,+                       random,+                       containers,+                       xml,+                       time,+                       deepseq,+                       abstract-par,+                       monad-par,+                       transformers,+                       llvm-pretty>= 0.5,+                       llvm-pretty-bc-parser+  if flag(fuzz)+      Buildable:       True+  else+      Buildable:       False
src/Data/LLVM/BitCode/Bitstream.hs view
@@ -13,6 +13,7 @@    , getBitstream, parseBitstream   , getBitCodeBitstream, parseBitCodeBitstream, parseBitCodeBitstreamLazy+  , parseMetadataStringLengths   ) where  import Data.LLVM.BitCode.BitString as BS@@ -412,7 +413,7 @@   | FieldVBR     !BitString   | FieldArray    [Field]   | FieldChar6   !Char-  | FieldBlob    !BitString+  | FieldBlob    !S.ByteString     deriving Show  getFields :: DefineAbbrev -> GetBits [Field]@@ -436,7 +437,11 @@    OpBlob -> do     len   <- vbrNum 6-    align32bits-    bytes <- fixed (len * 8)-    align32bits+    bytes <- bytestring len     return (FieldBlob bytes)+++-- Metadata String Lengths -----------------------------------------------------++parseMetadataStringLengths :: Int -> S.ByteString -> Either String [Int]+parseMetadataStringLengths n = C.runGet (runGetBits (replicateM n (vbrNum 6)))
src/Data/LLVM/BitCode/GetBits.hs view
@@ -2,6 +2,7 @@     GetBits   , runGetBits   , fixed, align32bits+  , bytestring   , label   , isolate   , try@@ -12,8 +13,9 @@  import Control.Applicative (Applicative(..),Alternative(..),(<$>)) import Control.Arrow (first)-import Control.Monad (MonadPlus(..))+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@@ -99,7 +101,20 @@     (rest,off) <- getBitString n'     return (bs `mappend` rest, off) +-- | 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" +-- | 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)++ -- Basic Interface -------------------------------------------------------------  -- | Read zeros up to an alignment of 32-bits.@@ -114,6 +129,13 @@ fixed n = GetBits $ \ off -> case off of   Aligned     -> getBitString n   SubWord l w -> getBitStringPartial n l w++-- | 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"  -- | Add a label to the error tag stack. label :: String -> GetBits a -> GetBits a
src/Data/LLVM/BitCode/IR/Attrs.hs view
@@ -30,4 +30,8 @@     13 -> return LinkerPrivate     14 -> return LinkerPrivateWeak     15 -> return LinkerPrivateWeakDefAuto+    16 -> return Weak+    17 -> return WeakODR+    18 -> return Linkonce+    19 -> return LinkonceODR     _  -> mzero
src/Data/LLVM/BitCode/IR/Constants.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-}  module Data.LLVM.BitCode.IR.Constants where@@ -30,8 +31,11 @@ -- Instruction Field Parsing ---------------------------------------------------  -- | Parse a binop from a field, returning its constructor in the AST.-binop :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)-binop  = choose <=< numeric+binopGeneric :: forall a.+                (ArithOp -> Typed PValue -> PValue -> a)+             -> (BitOp -> Typed PValue -> PValue -> a)+             -> Match Field (Maybe Int -> Typed PValue -> PValue -> a)+binopGeneric aop bop = choose <=< numeric   where    constant k kf = return $ \_mb x y ->@@ -62,67 +66,73 @@           Nothing -> i (k  False)    x y           Just w  -> i (k (exact w)) x y -  choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> PInstr)-  choose 0  = wrapFlags Arith Add   FAdd-  choose 1  = wrapFlags Arith Sub   FSub-  choose 2  = wrapFlags Arith Mul   FMul-  choose 3  = exactFlag Arith UDiv  FDiv-  choose 4  = exactFlag Arith SDiv  FDiv-  choose 5  = constant (Arith URem) (Arith FRem)-  choose 6  = constant (Arith SRem) (Arith FRem)-  choose 7  = wrapFlags Bit Shl  (error "invalid shl on floating point")-  choose 8  = exactFlag Bit Lshr (error "invalid lshr on floating point")-  choose 9  = exactFlag Bit Ashr (error "invalid ashr on floating point")-  choose 10 = constant (Bit And) (error "invalid and on floating point")-  choose 11 = constant (Bit Or)  (error "invalid or on floating point")-  choose 12 = constant (Bit Xor) (error "invalid xor on floating point")+  choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> a)+  choose 0  = wrapFlags aop Add   FAdd+  choose 1  = wrapFlags aop Sub   FSub+  choose 2  = wrapFlags aop Mul   FMul+  choose 3  = exactFlag aop UDiv  FDiv+  choose 4  = exactFlag aop SDiv  FDiv+  choose 5  = constant (aop URem) (aop FRem)+  choose 6  = constant (aop SRem) (aop FRem)+  choose 7  = wrapFlags bop Shl  (error "invalid shl on floating point")+  choose 8  = exactFlag bop Lshr (error "invalid lshr on floating point")+  choose 9  = exactFlag bop Ashr (error "invalid ashr on floating point")+  choose 10 = constant (bop And) (error "invalid and on floating point")+  choose 11 = constant (bop Or)  (error "invalid or on floating point")+  choose 12 = constant (bop Xor) (error "invalid xor on floating point")   choose _  = mzero -fcmpOp :: Match Field (Typed PValue -> PValue -> PInstr)+binop :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)+binop = binopGeneric Arith Bit++binopCE :: Match Field (Maybe Int -> Typed PValue -> PValue -> PValue)+binopCE = binopGeneric aop bop+  where+  aop op tv v = ValConstExpr (ConstArith op tv v)+  bop op tv v = ValConstExpr (ConstBit op tv v)++fcmpOp :: Match Field FCmpOp fcmpOp  = choose <=< numeric   where-  op        = return . FCmp-  choose :: Match Int (Typed PValue -> PValue -> PInstr)-  choose 0  = op Ffalse-  choose 1  = op Foeq-  choose 2  = op Fogt-  choose 3  = op Foge-  choose 4  = op Folt-  choose 5  = op Fole-  choose 6  = op Fone-  choose 7  = op Ford-  choose 8  = op Funo-  choose 9  = op Fueq-  choose 10 = op Fugt-  choose 11 = op Fuge-  choose 12 = op Fult-  choose 13 = op Fule-  choose 14 = op Fune-  choose 15 = op Ftrue+  choose :: Match Int FCmpOp+  choose 0  = return Ffalse+  choose 1  = return Foeq+  choose 2  = return Fogt+  choose 3  = return Foge+  choose 4  = return Folt+  choose 5  = return Fole+  choose 6  = return Fone+  choose 7  = return Ford+  choose 8  = return Funo+  choose 9  = return Fueq+  choose 10 = return Fugt+  choose 11 = return Fuge+  choose 12 = return Fult+  choose 13 = return Fule+  choose 14 = return Fune+  choose 15 = return Ftrue   choose _  = mzero -icmpOp :: Match Field (Typed PValue -> PValue -> PInstr)+icmpOp :: Match Field ICmpOp icmpOp  = choose <=< numeric   where-  op        = return . ICmp-  choose :: Match Int (Typed PValue -> PValue -> PInstr)-  choose 32 = op Ieq-  choose 33 = op Ine-  choose 34 = op Iugt-  choose 35 = op Iuge-  choose 36 = op Iult-  choose 37 = op Iule-  choose 38 = op Isgt-  choose 39 = op Isge-  choose 40 = op Islt-  choose 41 = op Isle+  choose :: Match Int ICmpOp+  choose 32 = return Ieq+  choose 33 = return Ine+  choose 34 = return Iugt+  choose 35 = return Iuge+  choose 36 = return Iult+  choose 37 = return Iule+  choose 38 = return Isgt+  choose 39 = return Isge+  choose 40 = return Islt+  choose 41 = return Isle   choose _  = mzero -castOp :: Match Field (Typed PValue -> Type -> PInstr)-castOp  = choose <=< numeric+castOpGeneric :: forall c. (ConvOp -> Maybe c) -> Match Field c+castOpGeneric op = choose <=< numeric   where-  op        = return . Conv-  choose :: Match Int (Typed PValue -> Type -> PInstr)+  choose :: Match Int c   choose 0  = op Trunc   choose 1  = op ZExt   choose 2  = op SExt@@ -137,24 +147,13 @@   choose 11 = op BitCast   choose _  = mzero +castOp :: Match Field (Typed PValue -> Type -> PInstr)+castOp = castOpGeneric (return . Conv)+ castOpCE :: Match Field (Typed PValue -> Type -> PValue)-castOpCE  = choose <=< numeric+castOpCE = castOpGeneric op   where-  op c      = return (\ tv t -> ValConstExpr (ConstConv c tv t))-  choose :: Match Int (Typed PValue -> Type -> PValue)-  choose 0  = op Trunc-  choose 1  = op ZExt-  choose 2  = op SExt-  choose 3  = op FpToUi-  choose 4  = op FpToSi-  choose 5  = op UiToFp-  choose 6  = op SiToFp-  choose 7  = op FpTrunc-  choose 8  = op FpExt-  choose 9  = op PtrToInt-  choose 10 = op IntToPtr-  choose 11 = op BitCast-  choose _  = mzero+  op c = return (\ tv t -> ValConstExpr (ConstConv c tv t))  -- Constants Block ------------------------------------------------------------- @@ -204,7 +203,7 @@   4 -> label "CST_CODE_INTEGER" $ do     let field = parseField r     ty <- getTy-    n  <- field 0 signed+    n  <- field 0 signedWord64     let val = fromMaybe (ValInteger (toInteger n)) $ do                 Integer 0 <- elimPrimType ty                 return (ValBool (n /= 0))@@ -268,7 +267,16 @@    -- [opcode,opval,opval]   10 -> label "CST_CODE_CE_BINOP" $ do-    notImplemented+    let field = parseField r+    ty      <- getTy+    mkInstr <- field 0 binopCE+    lopval  <- field 1 numeric+    ropval  <- field 2 numeric+    cxt     <- getContext+    let lv = forwardRef cxt lopval t+        rv = forwardRef cxt ropval t+    let mbWord = numeric =<< fieldAt 3 r+    return (getTy, Typed ty (mkInstr mbWord lv (typedValue rv)) : cs)    -- [opcode, opty, opval]   11 -> label "CST_CODE_CE_CAST" $ do@@ -283,9 +291,9 @@    -- [n x operands]   12 -> label "CST_CODE_CE_GEP" $ do-    ty   <- getTy-    args <- parseCeGep t r-    return (getTy,Typed ty (ValConstExpr (ConstGEP False args)):cs)+    ty <- getTy+    v <- parseCeGep False t r+    return (getTy,Typed ty v:cs)    -- [opval,opval,opval]   13 -> label "CST_CODE_CE_SELECT" $ do@@ -309,9 +317,23 @@   16 -> label "CST_CODE_CE_SHUFFLEVEC" $ do     notImplemented +  -- [opty, opval, opval, pred]   17 -> label "CST_CODE_CE_CMP" $ do-    notImplemented+    let field = parseField r+    opty <- getType                  =<< field 0 numeric+    op0  <- getConstantFwdRef t opty =<< field 1 numeric+    op1  <- getConstantFwdRef t opty =<< field 2 numeric +    let isFloat = isPrimTypeOf isFloatingPoint+    cst <- if isFloat opty || isVectorOf isFloat opty+              then do op <- field 3 fcmpOp+                      return (ConstFCmp op op0 op1)++              else do op <- field 3 icmpOp+                      return (ConstICmp op op0 op1)++    return (getTy, Typed (PrimType (Integer 1)) (ValConstExpr cst):cs)+   18 -> label "CST_CODE_INLINEASM_OLD" $ do     let field = parseField r     ty    <- getTy@@ -332,9 +354,9 @@    -- [n x operands]   20 -> label "CST_CODE_CE_INBOUNDS_GEP" $ do-    ty   <- getTy-    args <- parseCeGep t r-    return (getTy,Typed ty (ValConstExpr (ConstGEP True args)):cs)+    ty <- getTy+    v <- parseCeGep True t r+    return (getTy,Typed ty v:cs)    -- [funty,fnval,bb#]   21 -> label "CST_CODE_BLOCKADDRESS" $ do@@ -405,26 +427,27 @@ parseConstantEntry _ _ e =   fail ("constant block: unexpected: " ++ show e) -parseCeGep :: ValueTable -> Record -> Parse [Typed PValue]-parseCeGep t r = loop firstIdx-  where--  -- TODO: we should check the result type if it exists, but for now we-  -- ignore it.-  firstIdx = if odd (length (recordFields r)) then 1 else 0--  field = parseField r--  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)+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+        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)  parseWideInteger :: Record -> Parse Integer parseWideInteger r = do-  limbs <- parseFields r 0 signed+  limbs <- parseFields r 0 signedWord64   return (foldr (\l acc -> acc `shiftL` 64 + (toInteger l)) 0 limbs)  resolveNull :: Type -> Parse PValue
src/Data/LLVM/BitCode/IR/Function.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ViewPatterns #-} @@ -25,9 +26,7 @@ import qualified Data.Sequence as Seq import qualified Data.Traversable as T -import Debug.Trace - -- Function Aliases ------------------------------------------------------------  type AliasList = Seq.Seq PartialAlias@@ -86,16 +85,18 @@ -- | A define with a list of statements for a body, instead of a list of basic -- bocks. data PartialDefine = PartialDefine-  { partialAttrs   :: FunAttrs-  , partialSection :: Maybe String-  , partialRetType :: Type-  , partialName    :: Symbol-  , partialArgs    :: [Typed Ident]-  , partialVarArgs :: Bool-  , partialBody    :: BlockList-  , partialBlock   :: StmtList-  , partialBlockId :: !Int-  , partialSymtab  :: ValueSymtab+  { partialAttrs    :: FunAttrs+  , 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)  -- | Generate a partial function definition from a function prototype.@@ -108,16 +109,18 @@   symtab <- initialPartialSymtab    return PartialDefine-    { partialAttrs     = protoAttrs 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+    { partialAttrs    = protoAttrs 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 = []     }  -- | Set the statement list in a partial define.@@ -175,16 +178,22 @@   -- generate basic blocks.   withValueSymtab (partialSymtab pd) $ do     body <- finalizeBody lkp (partialBody pd)+    md <- finalizeMetadata (partialMetadata pd)     return Define-      { defAttrs   = partialAttrs pd-      , defRetType = partialRetType pd-      , defName    = partialName pd-      , defArgs    = partialArgs pd-      , defVarArgs = partialVarArgs pd-      , defBody    = body-      , defSection = partialSection pd+      { defAttrs    = partialAttrs pd+      , defRetType  = partialRetType pd+      , defName     = partialName pd+      , defArgs     = partialArgs pd+      , defVarArgs  = partialVarArgs pd+      , defBody     = body+      , defSection  = partialSection pd+      , defMetadata = md       } +finalizeMetadata :: PFnMdAttachments -> Parse FnMdAttachments+finalizeMetadata patt = Map.fromList <$> mapM f (Map.toList patt)+  where f (k,md) = (,) <$> getKind k <*> finalizePValMd md+ -- | Individual label resolution step. resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Parse BlockLabel resolveBlockLabel lkp mbSym = case mbSym of@@ -274,8 +283,11 @@ -- Function Block Parsing ------------------------------------------------------  -- | Parse the function block.-parseFunctionBlock :: [Entry] -> Parse PartialDefine-parseFunctionBlock ents = label "FUNCTION_BLOCK" $ enterFunctionDef $ do+parseFunctionBlock ::+  Int {- ^ unnamed globals so far -} ->+  [Entry] -> Parse PartialDefine+parseFunctionBlock unnamedGlobals ents =+  label "FUNCTION_BLOCK" $ enterFunctionDef $ do    -- parse the value symtab block first, so that names are present during the   -- rest of the parse@@ -292,22 +304,24 @@      -- generate the initial partial definition     pd  <- emptyPartialDefine proto-    rec pd' <- foldM (parseFunctionBlockEntry vt) pd ents+    rec pd' <- foldM (parseFunctionBlockEntry unnamedGlobals vt) pd ents         vt  <- getValueTable      -- merge the symbol table with the anonymous symbol table     return pd' { partialSymtab = partialSymtab pd' `Map.union` symtab }  -- | Parse the members of the function block-parseFunctionBlockEntry :: ValueTable -> PartialDefine -> Entry-                        -> Parse PartialDefine+parseFunctionBlockEntry ::+  Int {- ^ unnamed globals so far -} ->+  ValueTable -> PartialDefine -> Entry ->+  Parse PartialDefine -parseFunctionBlockEntry _ d (constantsBlockId -> Just es) = do+parseFunctionBlockEntry _ _ d (constantsBlockId -> Just es) = do   -- CONSTANTS_BLOCK   parseConstantsBlock es   return d -parseFunctionBlockEntry t d (fromEntry -> Just r) = case recordCode r of+parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of    -- [n]   1 -> label "FUNC_CODE_DECLARE_BLOCKS" (return d)@@ -717,8 +731,12 @@      let ty = typedType lhs         parseOp | isPrimTypeOf isFloatingPoint ty ||-                  isVectorOf (isPrimTypeOf isFloatingPoint) ty = fcmpOp-                | otherwise                       = icmpOp+                  isVectorOf (isPrimTypeOf isFloatingPoint) ty =+                  return . FCmp <=< fcmpOp++                | otherwise =+                  return . ICmp <=< icmpOp+     op <- field (ix+1) parseOp      let boolTy = Integer 1@@ -730,31 +748,40 @@   -- unknown    | otherwise -> fail ("instruction code " ++ show code ++ " is unknown") -parseFunctionBlockEntry _ d (valueSymtabBlockId -> Just _) = do+parseFunctionBlockEntry _ _ d (valueSymtabBlockId -> Just _) = do   -- this is parsed before any of the function block   return d -parseFunctionBlockEntry t d (metadataBlockId -> Just es) = do-  _ <- parseMetadataBlock t es-  return d+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 } -parseFunctionBlockEntry t d (metadataAttachmentBlockId -> Just es) = do-  (_,_,md) <- parseMetadataBlock t es-  return d { partialBody = addAttachments md (partialBody d) }+parseFunctionBlockEntry globals t d (metadataAttachmentBlockId -> Just es) = do+  (_,(globalUnnamedMds, localUnnamedMds),instrAtt,fnAtt)+     <- parseMetadataBlock globals t es+  unless (null localUnnamedMds)+     (fail "parseFunctionBlockEntry PANIC: unexpected local unnamed metadata")+  unless (null globalUnnamedMds)+     (fail "parseFunctionBlockEntry PANIC: unexpected global unnamed metadata")+  return d { partialBody     = addInstrAttachments instrAtt (partialBody d)+           , partialMetadata = Map.union fnAtt (partialMetadata d)+           } -parseFunctionBlockEntry _ d (abbrevDef -> Just _) =+parseFunctionBlockEntry _ _ d (abbrevDef -> Just _) =   -- ignore any abbreviation definitions   return d -parseFunctionBlockEntry _ d (uselistBlockId -> Just _) = do+parseFunctionBlockEntry _ _ d (uselistBlockId -> Just _) = do   -- ignore the uselist block   return d -parseFunctionBlockEntry _ _ e = do+parseFunctionBlockEntry _ _ _ e = do   fail ("function block: unexpected: " ++ show e) -addAttachments :: MetadataAttachments -> BlockList -> BlockList-addAttachments atts blocks = go 0 (Map.toList atts) (Seq.viewl blocks)+addInstrAttachments :: InstrMdAttachments -> BlockList -> BlockList+addInstrAttachments atts blocks = go 0 (Map.toList atts) (Seq.viewl blocks)   where   go _   []  (b Seq.:< bs) = b Seq.<| bs   go off mds (b Seq.:< bs) =@@ -838,7 +865,7 @@    getId n     | relIds    = do-      i   <- field n signed+      i   <- field n signedWord64       pos <- getNextId       return (pos - fromIntegral i)     | otherwise =@@ -999,7 +1026,7 @@        -- read the chunks of the number in.  each chunk represents one 64-bit       -- limb of a big num.-      chunks <- parseSlice r lowStart activeWords signed+      chunks <- parseSlice r lowStart activeWords signedWord64        -- decode limbs in big-endian order       let low = foldr (\l acc -> acc `shiftL` 64 + toInteger l) 0 chunks
src/Data/LLVM/BitCode/IR/Metadata.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecursiveDo #-}@@ -7,7 +8,10 @@   , parseMetadataKindEntry   , PartialUnnamedMd(..)   , finalizePartialUnnamedMd-  , MetadataAttachments+  , finalizePValMd+  , InstrMdAttachments+  , PFnMdAttachments+  , PKindMd   ) where  import Data.LLVM.BitCode.Bitstream@@ -19,23 +23,29 @@  import Control.Exception (throw) import Control.Monad (foldM,guard,mplus,unless,when)+import Data.List (mapAccumL) import Data.Maybe (fromMaybe)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as Char8 (unpack) import qualified Data.Map as Map import qualified Data.Traversable as T - -- 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 :: MdTable -> MetadataTable-emptyMetadataTable es = MetadataTable+emptyMetadataTable ::+  Int {- ^ globals seen so far -} ->+  MdTable -> MetadataTable+emptyMetadataTable globals es = MetadataTable   { mtEntries   = es-  , mtNextNode  = 0+  , mtNextNode  = globals   , mtNodes     = Map.empty   } @@ -59,11 +69,23 @@ 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'@@ -94,6 +116,17 @@   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@@ -102,18 +135,22 @@     return ix  data PartialMetadata = PartialMetadata-  { pmEntries       :: MetadataTable-  , pmNamedEntries  :: Map.Map String [Int]-  , pmNextName      :: Maybe String-  , pmAttachments   :: MetadataAttachments+  { pmEntries          :: MetadataTable+  , pmNamedEntries     :: Map.Map String [Int]+  , pmNextName         :: Maybe String+  , pmInstrAttachments :: InstrMdAttachments+  , pmFnAttachments    :: PFnMdAttachments   } deriving (Show) -emptyPartialMetadata :: MdTable -> PartialMetadata-emptyPartialMetadata es = PartialMetadata-  { pmEntries       = emptyMetadataTable es-  , pmNamedEntries  = Map.empty-  , pmNextName      = Nothing-  , pmAttachments   = Map.empty+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   }  updateMetadataTable :: (MetadataTable -> MetadataTable)@@ -123,10 +160,16 @@ setNextName :: String -> PartialMetadata -> PartialMetadata setNextName name pm = pm { pmNextName = Just name } -addAttachment :: Int -> [(String,PValMd)] -> PartialMetadata -> PartialMetadata-addAttachment instr md pm =-  pm { pmAttachments = Map.insert instr md (pmAttachments pm) }+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@@ -141,22 +184,24 @@               . pmNamedEntries  data PartialUnnamedMd = PartialUnnamedMd-  { pumIndex  :: Int-  , pumValues :: [Maybe PValMd]+  { pumIndex    :: Int+  , pumValues   :: PValMd   , pumDistinct :: Bool   } deriving (Show)  finalizePartialUnnamedMd :: PartialUnnamedMd -> Parse UnnamedMd-finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` fixLabels (pumValues pum)+finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` finalizePValMd (pumValues pum)   where-  -- map through the list and typed PValue to change labels to textual ones-  fixLabels      = T.mapM (T.mapM (relabel (const requireBbEntryName)))-  mkUnnamedMd vs = UnnamedMd+  mkUnnamedMd v = UnnamedMd     { umIndex  = pumIndex pum-    , umValues = vs+    , 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@@ -166,28 +211,47 @@   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 (ValMdNode vs) } <- Map.lookup ref es+    Typed { typedValue = ValMd v } <- Map.lookup ref es     return PartialUnnamedMd       { pumIndex  = ix-      , pumValues = vs+      , pumValues = v       , pumDistinct = d       } -type MetadataAttachments = Map.Map Int [(String,PValMd)]-type ParsedMetadata = ([NamedMd],([PartialUnnamedMd],[PartialUnnamedMd]),MetadataAttachments)+type InstrMdAttachments = Map.Map Int [(KindMd,PValMd)] +type PKindMd = Int+type PFnMdAttachments = Map.Map PKindMd PValMd++type ParsedMetadata =+  ( [NamedMd]+  , ([PartialUnnamedMd],[PartialUnnamedMd])+  , InstrMdAttachments+  , PFnMdAttachments+  )+ parsedMetadata :: PartialMetadata -> ParsedMetadata-parsedMetadata pm = (namedEntries pm, unnamedEntries pm, pmAttachments pm)+parsedMetadata pm =+  ( namedEntries pm+  , unnamedEntries pm+  , pmInstrAttachments pm+  , pmFnAttachments pm+  )  -- Metadata Parsing ------------------------------------------------------------ -parseMetadataBlock :: ValueTable -> [Entry] -> Parse ParsedMetadata-parseMetadataBlock vt es = label "METADATA_BLOCK" $ do+parseMetadataBlock ::+  Int {- ^ globals seen so far -} ->+  ValueTable -> [Entry] -> Parse ParsedMetadata+parseMetadataBlock globals vt es = label "METADATA_BLOCK" $ do   ms <- getMdTable-  let pm0 = emptyPartialMetadata ms+  let pm0 = emptyPartialMetadata globals ms   rec pm <- foldM (parseMetadataEntry vt (pmEntries pm)) pm0 es   let entries = pmEntries pm   setMdTable (mtEntries entries)@@ -201,7 +265,8 @@ -- 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+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@@ -242,8 +307,11 @@     addKind kind name     return pm -  -- [distinct, line, col, scope, inlined-at?] +  -- [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@@ -270,10 +338,19 @@    -- [m x [value, [n x [id, mdnode]]]   11 -> label "METADATA_ATTACHMENT" $ do-    let field = parseField r-    inst <- field 0 numeric-    md   <- parseAttachment r-    return $! addAttachment inst md pm+    let recordSize = length (recordFields r)+    when (recordSize == 0)+      (fail "Invalid record")+    ctx <- getContext+    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@@ -282,65 +359,199 @@     header <- parseField r 3 string     -- TODO: parse all remaining fields     fail "not yet implemented"+   13 -> label "METADATA_SUBRANGE" $ do-    isDistinct <- parseField r 0 numeric-    parseField r 1 numeric-    parseField r 2 signed-    -- TODO-    fail "not yet implemented"+    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-    isDistinct <- parseField r 0 numeric-    parseField r 1 signed-    parseField r 2 string-    -- TODO-    fail "not yet implemented"+    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-    isDistinct <- parseField r 0 numeric-    parseField r 1 numeric-    name <- parseField r 2 numeric-    parseField r 3 numeric-    parseField r 4 numeric-    parseField r 5 numeric-    -- TODO-    fail "not yet implemented"+    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-    isDistinct <- parseField r 0 numeric-    name <- parseField r 1 numeric-    dir  <- parseField r 2 numeric-    -- TODO-    fail "not yet implemented"+    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-    -- TODO-    fail "not yet implemented"+    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-    -- TODO-    fail "not yet implemented"+    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-    -- TODO-    fail "not yet implemented"+    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-    -- TODO-    fail "not yet implemented"+    let recordSize = length (recordFields r)+    when (recordSize < 14 || recordSize > 16)+      (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              <- 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+    return $! updateMetadataTable+      (addDebugInfo isDistinct (DebugInfoCompileUnit DICompileUnit {..})) pm++   21 -> label "METADATA_SUBPROGRAM" $ do-    -- TODO-    fail "not yet implemented"+    -- 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 numeric-    mdForwardRefOrNull cxt mt <$> parseField r 1 numeric-    mdForwardRefOrNull cxt mt <$> parseField r 2 numeric-    parseField r 3 numeric-    parseField r 4 numeric-    -- TODO-    fail "not yet implemented"+    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 numeric-    mdForwardRefOrNull cxt mt <$> parseField r 1 numeric-    mdForwardRefOrNull cxt mt <$> parseField r 2 numeric-    parseField r 3 numeric-    -- TODO-    fail "not yet implemented"+    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@@ -365,15 +576,58 @@     mdForwardRefOrNull cxt mt <$> parseField r 4 numeric     -- TODO     fail "not yet implemented"+   27 -> label "METADATA_GLOBAL_VAR" $ do-    -- TODO-    fail "not yet implemented"+    when (length (recordFields r) /= 11)+      (fail "Invalid record")++    ctx <- getContext+    isDistinct <- parseField r 0 nonzero+    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+    return $! updateMetadataTable+      (addDebugInfo+         isDistinct+         (DebugInfoGlobalVariable DIGlobalVariable{..})) pm+   28 -> label "METADATA_LOCAL_VAR" $ do-    -- TODO-    fail "not yet implemented"+    -- 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)+        adj i | recordSize > 8 = i + 1+              | otherwise      = i+    when (recordSize < 8 || recordSize > 10)+      (fail "Invalid record")++    ctx <- getContext+    isDistinct <- parseField r 0 nonzero+    dilvScope  <- mdForwardRefOrNull ctx mt <$> parseField r (adj 1) numeric+    dilvName   <- mdStringOrNull ctx mt <$> parseField r (adj 2) numeric+    dilvFile   <- mdForwardRefOrNull ctx mt <$> parseField r (adj 3) numeric+    dilvLine   <- parseField r (adj 4) numeric+    dilvType   <- mdForwardRefOrNull 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-    -- TODO-    fail "not yet implemented"+    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"@@ -414,13 +668,42 @@     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++  36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do     -- TODO     fail "not yet implemented"-  36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do++  37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do     -- TODO     fail "not yet implemented" +  38 -> label "METADATA_INDEX_OFFSET" $ do+    -- TODO+    fail "not yet implemented"++  39 -> label "METADATA_INDEX" $ do+    -- TODO+    fail "not yet implemented"+   code -> fail ("unknown record code: " ++ show code)  parseMetadataEntry _ _ pm (abbrevDef -> Just _) =@@ -429,14 +712,13 @@ parseMetadataEntry _ _ _ r =   fail ("unexpected: " ++ show r) --parseAttachment :: Record -> Parse [(String,PValMd)]-parseAttachment r = loop (length (recordFields r) - 1) []+parseAttachment :: Record -> Int -> Parse [(PKindMd,PValMd)]+parseAttachment r l = loop (length (recordFields r) - 1) []   where-  loop 0 acc = return acc-  loop n acc = do-    kind <- getKind     =<< parseField r (n - 1) numeric-    md   <- getMetadata =<< parseField r  n      numeric+  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)  -- | Parse a metadata node.
src/Data/LLVM/BitCode/IR/Module.hs view
@@ -39,6 +39,7 @@   , partialNamedMd    :: [NamedMd]   , partialUnnamedMd  :: [PartialUnnamedMd]   , partialSections   :: Seq.Seq String+  , partialSourceName :: !(Maybe String)   }  emptyPartialModule :: PartialModule@@ -54,6 +55,7 @@   , partialNamedMd    = mempty   , partialUnnamedMd  = mempty   , partialSections   = mempty+  , partialSourceName = mempty   }  -- | Fixup the global variables and declarations, and return the completed@@ -66,7 +68,7 @@   unnamed  <- T.mapM finalizePartialUnnamedMd (partialUnnamedMd pm)   types    <- resolveTypeDecls   let lkp = lookupBlockName (partialDefines pm)-  defines  <- T.mapM (finalizePartialDefine lkp) (partialDefines pm)+  defines <- T.mapM (finalizePartialDefine lkp) (partialDefines pm)   return emptyModule     { modDataLayout = partialDataLayout pm     , modNamedMd    = partialNamedMd pm@@ -128,8 +130,12 @@  parseModuleBlockEntry pm (functionBlockId -> Just es) = do   -- FUNCTION_BLOCK_ID-  def <- parseFunctionBlock es-  return pm { partialDefines = partialDefines pm Seq.|> def }+  let unnamedGlobalsCount = length (partialUnnamedMd pm)+  def <- parseFunctionBlock unnamedGlobalsCount es+  let def' = def { partialGlobalMd = [] }+  return pm { partialDefines = partialDefines pm Seq.|> def'+            , partialUnnamedMd = partialGlobalMd def ++ partialUnnamedMd pm+            }  parseModuleBlockEntry pm (paramattrBlockId -> Just _) = do   -- PARAMATTR_BLOCK_ID@@ -144,7 +150,8 @@ parseModuleBlockEntry pm (metadataBlockId -> Just es) = do   -- METADATA_BLOCK_ID   vt <- getValueTable-  (ns,(gs,_),_) <- parseMetadataBlock vt es+  let globalsSoFar = length (partialUnnamedMd pm)+  (ns,(gs,_),_,_) <- parseMetadataBlock globalsSoFar vt es   return pm     { partialNamedMd   = partialNamedMd   pm ++ ns     , partialUnnamedMd = partialUnnamedMd pm ++ gs@@ -224,9 +231,10 @@   -- MODULE_CODE_METADATA_VALUES_UNUSED   return pm -parseModuleBlockEntry _ (moduleCodeSourceFilename -> Just _) = do+parseModuleBlockEntry pm (moduleCodeSourceFilename -> Just r) = do   -- MODULE_CODE_SOURCE_FILENAME-  fail "MODULE_CODE_SOURCE_FILENAME"+  do str <- parseField r 0 cstring+     return pm { partialSourceName = Just str }  parseModuleBlockEntry _ (moduleCodeHash -> Just _) = do   -- MODULE_CODE_HASH
src/Data/LLVM/BitCode/IR/Values.hs view
@@ -2,6 +2,7 @@  module Data.LLVM.BitCode.IR.Values (     getValueTypePair+  , getConstantFwdRef   , getValue   , getFnValueById   , parseValueSymbolTableBlock@@ -21,6 +22,18 @@  -- 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)@@ -67,7 +80,6 @@    _ -> do     mb <- lookupValueAbs (fromIntegral n)-    -- TODO: lookup in the metadata table     case mb of        Just tv -> return tv
src/Data/LLVM/BitCode/Match.hs view
@@ -48,7 +48,7 @@ -- | Get the nth element of a list. index :: Int -> Match [a] a index n as = do-  guard (n < length as)+  guard (n >= 0 && n < length as)   return (as !! n)  -- | Drop elements of a list until a predicate matches.
src/Data/LLVM/BitCode/Parse.hs view
@@ -549,8 +549,12 @@                Map.lookup (SymTabFNEntry n) symtab   case mentry of     Just i  -> return (renderName i)-    Nothing -> fail ("entry " ++ show n ++ " is missing from the symbol table"-             ++ "\n" ++ show symtab)+    Nothing ->+      do isRel <- getRelIds+         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)@@ -621,4 +625,4 @@   let KindTable { .. } = psKinds ps   case Map.lookup kind ktNames of     Just name -> return name-    Nothing   -> fail ("Unknown kind id: " ++ show kind)+    Nothing   -> fail ("Unknown kind id: " ++ show kind ++ "\nKind table: " ++ show (psKinds ps))
src/Data/LLVM/BitCode/Record.hs view
@@ -5,9 +5,11 @@ import Data.LLVM.BitCode.Match import Data.LLVM.BitCode.Parse -import Data.Bits (testBit,shiftR,bit)+import Data.Bits (Bits,testBit,shiftR,bit) import Data.Char (chr)+import Data.Int  (Int64) import Data.Word (Word64)+import Data.ByteString (ByteString)  import Control.Monad ((<=<),MonadPlus(..),guard) @@ -74,6 +76,11 @@ fieldArray p (FieldArray fs) = mapM p fs fieldArray _ _               = mzero +-- | Match a blob field.+fieldBlob :: Match Field ByteString+fieldBlob (FieldBlob bs) = return bs+fieldBlob _              = mzero+ type LookupField a = Int -> Match Field a -> Parse a  -- | Flatten arrays inside a record.@@ -110,9 +117,8 @@ numeric :: Num a => Match Field a numeric  = fmap fromBitString . (fieldLiteral ||| fieldFixed ||| fieldVbr) --- | Parse a @Field@ as a sign-encoded number.-signed :: Match Field Word64-signed  = fmap decode . (fieldLiteral ||| fieldFixed ||| fieldVbr)+signedImpl :: (Bits a, Num a) => Match Field a+signedImpl = fmap decode . (fieldLiteral ||| fieldFixed ||| fieldVbr)   where   decode bs     | not (testBit n 0) =         n `shiftR` 1@@ -120,6 +126,14 @@     | otherwise         = bit 63 -- not really right, but it's what llvm does     where     n = fromBitString bs++-- | Parse a @Field@ as a sign-encoded number.+signedWord64 :: Match Field Word64+signedWord64 = signedImpl++-- | Parse a @Field@ as a sign-encoded number.+signedInt64 :: Match Field Int64+signedInt64 = signedImpl  boolean :: Match Field Bool boolean  = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr)