From ef2079bc1c405bbc85686759770270131792187d Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 22 Jun 2022 07:32:59 -0400 Subject: [PATCH] Replace LLVM debug utilities with llvm-pretty Fixes #1662. --- src/SAWScript/Crucible/LLVM/Skeleton.hs | 78 +++++-------------------- 1 file changed, 13 insertions(+), 65 deletions(-) diff --git a/src/SAWScript/Crucible/LLVM/Skeleton.hs b/src/SAWScript/Crucible/LLVM/Skeleton.hs index f455d4233f..d55d5cf71b 100644 --- a/src/SAWScript/Crucible/LLVM/Skeleton.hs +++ b/src/SAWScript/Crucible/LLVM/Skeleton.hs @@ -27,6 +27,7 @@ import Control.Arrow import Control.Monad import Control.Lens +import qualified Data.IntMap.Strict as IntMap import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text @@ -36,6 +37,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Text.LLVM as LLVM +import qualified Text.LLVM.DebugUtils as LLVM -------------------------------------------------------------------------------- -- ** Skeletons @@ -101,43 +103,27 @@ parseType (LLVM.Array i t) = pure $ TypeSkeleton t True ] parseType t = pure $ TypeSkeleton t False [] -debugInfoGlobalLines :: LLVM.Module -> Map Text Int -debugInfoGlobalLines = go . LLVM.modUnnamedMd - where - go :: [LLVM.UnnamedMd] -> Map Text Int - go (LLVM.UnnamedMd - { LLVM.umValues = LLVM.ValMdDebugInfo - (LLVM.DebugInfoGlobalVariable LLVM.DIGlobalVariable - { LLVM.digvName = Just n - , LLVM.digvLine = l - } - ) - }:xs) = Map.insert (Text.pack n) (fromIntegral l) $ go xs - go (_:xs) = go xs - go [] = Map.empty - -parseGlobal :: Map Text Int -> LLVM.Global -> IO GlobalSkeleton +parseGlobal :: Map String Int -> LLVM.Global -> IO GlobalSkeleton parseGlobal ls LLVM.Global { LLVM.globalSym = LLVM.Symbol s , LLVM.globalType = t , LLVM.globalValue = v , LLVM.globalAttrs = LLVM.GlobalAttrs { LLVM.gaConstant = c } } = do - let nm = Text.pack s ty <- parseType t pure GlobalSkeleton { _globSkelName = Text.pack s - , _globSkelLoc = flip Location Nothing <$> Map.lookup nm ls + , _globSkelLoc = flip Location Nothing <$> Map.lookup s ls , _globSkelType = ty , _globSkelMutable = not c , _globSkelInitialized = isJust v } -parseArg :: LLVM.Typed LLVM.Ident -> (Maybe Text, Maybe Location) -> IO ArgSkeleton +parseArg :: LLVM.Typed LLVM.Ident -> (Maybe String, Maybe Location) -> IO ArgSkeleton parseArg LLVM.Typed { LLVM.typedType = t } (nm, loc) = do ty <- parseType t pure ArgSkeleton - { _argSkelName = nm + { _argSkelName = Text.pack <$> nm , _argSkelLoc = loc , _argSkelType = ty } @@ -167,7 +153,7 @@ stmtDebugDeclares , Just (LLVM.ValMdLoc LLVM.DebugLoc { LLVM.dlLine = line, LLVM.dlCol = col }) <- lookup "dbg" md = Map.insert (fromIntegral a) (Location (fromIntegral line) . Just $ fromIntegral col) $ stmtDebugDeclares stmts stmtDebugDeclares - (LLVM.Effect + (LLVM.Effect (LLVM.Call _ _ (LLVM.ValSymbol (LLVM.Symbol s)) [ _ @@ -185,45 +171,7 @@ stmtDebugDeclares (_:stmts) = stmtDebugDeclares stmts defineName :: LLVM.Define -> Text defineName LLVM.Define { LLVM.defName = LLVM.Symbol s } = Text.pack s -debugInfoArgNames :: LLVM.Module -> LLVM.Define -> Map Int Text -debugInfoArgNames m d = - case Map.lookup "dbg" $ LLVM.defMetadata d of - Just (LLVM.ValMdRef s) -> scopeArgs s - _ -> Map.empty - where - scopeArgs :: Int -> Map Int Text - scopeArgs s = go $ LLVM.modUnnamedMd m - where go :: [LLVM.UnnamedMd] -> Map Int Text - go [] = Map.empty - go (LLVM.UnnamedMd - { LLVM.umValues = - LLVM.ValMdDebugInfo - (LLVM.DebugInfoLocalVariable - LLVM.DILocalVariable - { LLVM.dilvScope = Just (LLVM.ValMdRef s') - , LLVM.dilvArg = a - , LLVM.dilvName = Just n - })}:xs) = - if s == s' then Map.insert (fromIntegral a) (Text.pack n) $ go xs else go xs - go (_:xs) = go xs - -debugInfoDefineLines :: LLVM.Module -> Map Text Int -debugInfoDefineLines = go . LLVM.modUnnamedMd - where - go :: [LLVM.UnnamedMd] -> Map Text Int - go (LLVM.UnnamedMd - { LLVM.umValues = LLVM.ValMdDebugInfo - (LLVM.DebugInfoSubprogram LLVM.DISubprogram - { LLVM.dispName = Just n - , LLVM.dispIsDefinition = True - , LLVM.dispLine = l - } - ) - }:xs) = Map.insert (Text.pack n) (fromIntegral l) $ go xs - go (_:xs) = go xs - go [] = Map.empty - -parseDefine :: Map Text Int -> LLVM.Module -> LLVM.Define -> IO FunctionSkeleton +parseDefine :: Map String Int -> LLVM.Module -> LLVM.Define -> IO FunctionSkeleton parseDefine _ _ LLVM.Define { LLVM.defVarArgs = True } = fail "Skeleton generation does not support varargs" parseDefine ls m d@LLVM.Define @@ -233,13 +181,13 @@ parseDefine ls m d@LLVM.Define , LLVM.defRetType = ret } = do let stmts = mconcat $ LLVM.bbStmts <$> body - let argNames = debugInfoArgNames m d + let argNames = LLVM.debugInfoArgNames m d let debugDeclares = stmtDebugDeclares stmts - argSkels <- zipWithM parseArg args $ (flip Map.lookup argNames &&& flip Map.lookup debugDeclares) <$> [1, 2..] + argSkels <- zipWithM parseArg args $ (flip IntMap.lookup argNames &&& flip Map.lookup debugDeclares) <$> [1, 2..] retTy <- parseType ret pure FunctionSkeleton { _funSkelName = Text.pack s - , _funSkelLoc = flip Location Nothing <$> Map.lookup (Text.pack s) ls + , _funSkelLoc = flip Location Nothing <$> Map.lookup s ls , _funSkelArgs = argSkels , _funSkelRet = retTy , _funSkelCalls = Set.intersection @@ -249,8 +197,8 @@ parseDefine ls m d@LLVM.Define moduleSkeleton :: LLVM.Module -> IO ModuleSkeleton moduleSkeleton ast = do - globs <- mapM (parseGlobal $ debugInfoGlobalLines ast) $ LLVM.modGlobals ast - funs <- mapM (parseDefine (debugInfoDefineLines ast) ast) $ LLVM.modDefines ast + globs <- mapM (parseGlobal $ LLVM.debugInfoGlobalLines ast) $ LLVM.modGlobals ast + funs <- mapM (parseDefine (LLVM.debugInfoDefineLines ast) ast) $ LLVM.modDefines ast pure $ ModuleSkeleton { _modSkelGlobals = Map.fromList $ (\g -> (g ^. globSkelName, g)) <$> globs , _modSkelFunctions = Map.fromList $ (\f -> (f ^. funSkelName, f)) <$> funs