diff --git a/fuzzing/Main.hs b/fuzzing/Main.hs --- a/fuzzing/Main.hs +++ b/fuzzing/Main.hs @@ -25,7 +25,7 @@ (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo) import System.Directory (copyFile, createDirectoryIfMissing, findExecutable, getFileSize, - getPermissions, setPermissions, setOwnerExecutable) + getPermissions, setPermissions, setOwnerExecutable, makeAbsolute) import System.Environment (getArgs, getProgName, lookupEnv) import System.Exit (ExitCode(..), exitFailure, exitSuccess) import System.FilePath ((), (<.>), dropExtension) @@ -245,6 +245,8 @@ TestFail st _ TestSrc{..} err -> do copyFile (tmpDir srcFile) (clangRoot srcFile) writeFile (clangRoot srcFile <.> show st <.> "err") err + let bcFile = dropExtension srcFile <.> "bc" + copyFile (tmpDir bcFile) (clangRoot bcFile) when (or [ st == DisasmStage && optReduceDisasm opts , st == AsStage && optReduceAs opts , st == ExecStage && optReduceExec opts ]) $ @@ -267,6 +269,7 @@ Nothing -> "" Just ver -> "--llvm-version=" ++ ver copyFile (clangRoot srcFile) srcReduced + absClangRoot <- makeAbsolute clangRoot 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 @@ -286,6 +289,8 @@ [] -> Nothing msg -> Just (unwords msg) grepPat ExecStage = error "no grep pattern for exec reduction" + bcFile = baseName <.> "bc" + llFile = baseName <.> "ll" scriptHeader = [ "#!/usr/bin/env bash" , "# Consider this script a best guess template for reducing failing" @@ -298,33 +303,39 @@ ] buildBc = unwords [ clangExe, "-I", csmithPath, flags, "-c" - , "-emit-llvm", baseName ++ "-reduced.c", "-o", baseName <.> "bc" + , "-emit-llvm", baseName ++ "-reduced.c", "-o", bcFile ] buildLl = unwords [ - "llvm-disasm", llvmVersion, baseName <.> "bc", ">", baseName <.> "ll" + "llvm-disasm", llvmVersion, bcFile, ">", llFile ] + copyBc = unwords [ + "cp", bcFile, absClangRoot bcFile + ] script DisasmStage = unlines $ scriptHeader ++ [ buildBc - , unwords [ "llvm-disasm", llvmVersion, baseName <.> "bc", "2>&1 |" + , copyBc + , unwords [ "llvm-disasm", llvmVersion, bcFile, "2>&1 |" , "grep", show (fromMaybe "" (grepPat st)) ] ] script AsStage = unlines $ scriptHeader ++ [ buildBc + , copyBc , buildLl , unwords [ clangExe, "-I", csmithPath, flags, "-c" - , baseName <.> "ll", "-o", baseName <.> "o", "2>&1 |" + , llFile, "-o", baseName <.> "o", "2>&1 |" , "fgrep ", show (fromMaybe "" (grepPat st)) ] ] script ExecStage = unlines $ scriptHeader ++ [ buildBc + , copyBc , buildLl , unwords [ clangExe, "-I", csmithPath, flags - , baseName <.> "bc", "-o", "golden" + , bcFile, "-o", "golden" ] , unwords [ clangExe, "-I", csmithPath, flags - , baseName <.> "ll", "-o", "ours" + , llFile, "-o", "ours" ] , "GOLDEN=$(timeout 10 ./golden)" , "[ \"$GOLDEN\" != \"$(./ours)\" ]" diff --git a/llvm-pretty-bc-parser.cabal b/llvm-pretty-bc-parser.cabal --- a/llvm-pretty-bc-parser.cabal +++ b/llvm-pretty-bc-parser.cabal @@ -1,5 +1,5 @@ Name: llvm-pretty-bc-parser -Version: 0.3.0.1 +Version: 0.3.1.0 License: BSD3 License-file: LICENSE Author: Trevor Elliott @@ -57,7 +57,7 @@ fgl >= 5.5, cereal >= 0.3.5.2, bytestring >= 0.9.1, - llvm-pretty>= 0.6 + llvm-pretty>= 0.7 Executable llvm-disasm Main-is: LLVMDis.hs @@ -73,7 +73,7 @@ fgl >= 5.5, fgl-visualize >= 0.1, cereal >= 0.3.5.2, - llvm-pretty>= 0.5, + llvm-pretty>= 0.7, llvm-pretty-bc-parser Test-suite disasm-test @@ -87,7 +87,7 @@ directory, bytestring, filepath, - llvm-pretty>= 0.5, + llvm-pretty>= 0.7, llvm-pretty-bc-parser Executable fuzz-llvm-disasm @@ -109,7 +109,7 @@ abstract-par, monad-par, transformers, - llvm-pretty>= 0.5, + llvm-pretty>= 0.7, llvm-pretty-bc-parser if flag(fuzz) Buildable: True diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -74,6 +74,7 @@ , decName = Symbol (protoName fp) , decArgs = args , decVarArgs = va + , decAttrs = [] } _ -> fail "invalid type on function prototype" @@ -85,7 +86,8 @@ -- | A define with a list of statements for a body, instead of a list of basic -- bocks. data PartialDefine = PartialDefine - { partialAttrs :: FunAttrs + { partialLinkage :: Maybe Linkage + , partialGC :: Maybe GC , partialSection :: Maybe String , partialRetType :: Type , partialName :: Symbol @@ -109,7 +111,8 @@ symtab <- initialPartialSymtab return PartialDefine - { partialAttrs = protoAttrs proto + { partialLinkage = protoLinkage proto + , partialGC = protoGC proto , partialSection = protoSect proto , partialRetType = rty , partialName = Symbol (protoName proto) @@ -180,7 +183,9 @@ body <- finalizeBody lkp (partialBody pd) md <- finalizeMetadata (partialMetadata pd) return Define - { defAttrs = partialAttrs pd + { defLinkage = partialLinkage pd + , defGC = partialGC pd + , defAttrs = [] , defRetType = partialRetType pd , defName = partialName pd , defArgs = partialArgs pd diff --git a/src/Data/LLVM/BitCode/IR/Globals.hs b/src/Data/LLVM/BitCode/IR/Globals.hs --- a/src/Data/LLVM/BitCode/IR/Globals.hs +++ b/src/Data/LLVM/BitCode/IR/Globals.hs @@ -50,7 +50,7 @@ else elimPtrTo ptrty `mplus` fail "Invalid type for value" name <- entryName n - _ <- pushValue (Typed ptrty (ValSymbol (Symbol name))) + _ <- pushValue (Typed (PtrTo ty) (ValSymbol (Symbol name))) let valid | initid == 0 = Nothing | otherwise = Just (initid - 1) attrs = GlobalAttrs diff --git a/src/Data/LLVM/BitCode/IR/Metadata.hs b/src/Data/LLVM/BitCode/IR/Metadata.hs --- a/src/Data/LLVM/BitCode/IR/Metadata.hs +++ b/src/Data/LLVM/BitCode/IR/Metadata.hs @@ -25,6 +25,7 @@ import Control.Monad (foldM,guard,mplus,unless,when) import Data.List (mapAccumL) import Data.Maybe (fromMaybe) +import Data.Bits (shiftR, testBit) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as Char8 (unpack) import qualified Data.Map as Map @@ -447,7 +448,7 @@ 20 -> label "METADATA_COMPILE_UNIT" $ do let recordSize = length (recordFields r) - when (recordSize < 14 || recordSize > 16) + when (recordSize < 14 || recordSize > 17) (fail "Invalid record") ctx <- getContext @@ -479,6 +480,10 @@ 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 @@ -578,11 +583,15 @@ fail "not yet implemented" 27 -> label "METADATA_GLOBAL_VAR" $ do - when (length (recordFields r) /= 11) - (fail "Invalid record") + let len = length (recordFields r) + unless (11 <= len && len <= 12) + (fail "Unexpected number of record fields") - ctx <- getContext - isDistinct <- parseField r 0 nonzero + 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 @@ -593,6 +602,8 @@ 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 @@ -693,8 +704,14 @@ fail "not yet implemented" 37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do - -- TODO - fail "not yet implemented" + 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 -- TODO diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs --- a/src/Data/LLVM/BitCode/IR/Module.hs +++ b/src/Data/LLVM/BitCode/IR/Module.hs @@ -304,13 +304,12 @@ let proto = FunProto { protoType = ty - , protoAttrs = emptyFunAttrs - { funLinkage = do - -- we emit a Nothing here to maintain output compatibility with - -- llvm-dis when linkage is External - guard (link /= External) - return link - } + , protoLinkage = + do -- we emit a Nothing here to maintain output compatibility with + -- llvm-dis when linkage is External + guard (link /= External) + return link + , protoGC = Nothing , protoName = name , protoIndex = ix , protoSect = section diff --git a/src/Data/LLVM/BitCode/Parse.hs b/src/Data/LLVM/BitCode/Parse.hs --- a/src/Data/LLVM/BitCode/Parse.hs +++ b/src/Data/LLVM/BitCode/Parse.hs @@ -389,7 +389,8 @@ data FunProto = FunProto { protoType :: Type - , protoAttrs :: FunAttrs + , protoLinkage :: Maybe Linkage + , protoGC :: Maybe GC , protoName :: String , protoIndex :: Int , protoSect :: Maybe String