From 64afb8724850e1c14dcfdaa2553fca471d532b31 Mon Sep 17 00:00:00 2001 From: Valentin Robert Date: Fri, 11 Aug 2023 12:11:58 -0700 Subject: [PATCH] use Doc for discovery error messages For debugging block terminator classifying failures, it helps to have much more information. This switches from a `Text`-based error message to a `Doc`-based error message to support easier rendering of complex error descriptions, including a listing of the instructions leading to classiying failures for block terminator statements. --- reopt/Main_reopt.hs | 1 + src/Reopt.hs | 24 ++++++++++++++++++---- src/Reopt/ELFArchInfo.hs | 3 ++- src/Reopt/Events.hs | 41 ++++++++++++++------------------------ src/Reopt/Events/Export.hs | 7 ++++++- 5 files changed, 44 insertions(+), 32 deletions(-) diff --git a/reopt/Main_reopt.hs b/reopt/Main_reopt.hs index 2be1ccc4..1f3543a2 100644 --- a/reopt/Main_reopt.hs +++ b/reopt/Main_reopt.hs @@ -41,6 +41,7 @@ import Data.Macaw.Discovery ( memory, ppDiscoveryStateBlocks, ) +import Data.Macaw.X86 () import Data.Maybe ( fromMaybe, isJust, diff --git a/src/Reopt.hs b/src/Reopt.hs index 704ca6ee..5283df6f 100644 --- a/src/Reopt.hs +++ b/src/Reopt.hs @@ -152,6 +152,7 @@ import Data.Macaw.Analysis.RegisterUse ( ppRegisterUseErrorReason, ) import Data.Macaw.CFG ( + ArchConstraints, ArchFn, ArchReg, ArchSegmentOff, @@ -223,6 +224,7 @@ import Data.Vector qualified as V import Data.Word (Word16, Word32, Word64) import Flexdis86 qualified as F import Numeric (showHex) +import Prettyprinter qualified as PP import Reopt.ArgResolver ( ArgResolver, ArgResolverError (UnsupportedArgType, UnsupportedReturnType), @@ -595,7 +597,10 @@ reoptRunInit m = Left e -> pure (Left (Events.ReoptInitError e)) Right v -> c v -checkBlockError :: Macaw.ParsedBlock arch ids -> Maybe Events.DiscoveryError +checkBlockError :: + ArchConstraints arch => + Macaw.ParsedBlock arch ids -> + Maybe Events.DiscoveryError checkBlockError b = do let a = memWordValue $ addrOffset $ segoffAddr $ Macaw.pblockAddr b case Macaw.pblockTermStmt b of @@ -615,7 +620,7 @@ checkBlockError b = do , Events.discErrorBlockAddr = a , Events.discErrorBlockSize = Macaw.blockSize b , Events.discErrorBlockInsnIndex = length (Macaw.pblockStmts b) - , Events.discErrorMessage = msg + , Events.discErrorMessage = fromString $ T.unpack msg } Macaw.ClassifyFailure _ reasons -> Just $! @@ -625,13 +630,22 @@ checkBlockError b = do , Events.discErrorBlockSize = Macaw.blockSize b , Events.discErrorBlockInsnIndex = length (Macaw.pblockStmts b) , Events.discErrorMessage = - "Unclassified control flow transfer.\n" - <> T.intercalate "\n" (map (T.pack . ("→ " <>)) reasons) + PP.vcat + [ "Unclassified control flow transfer" + , PP.indent 2 $ + PP.vcat + [ "Block statements:" + , PP.indent 2 $ PP.vcat $ map PP.viaShow (Macaw.pblockStmts b) + , "Classifier failures:" + , PP.indent 2 $ PP.vcat $ map PP.viaShow reasons + ] + ] } _ -> Nothing -- | Prepend discovery event to list of reopt log evnts. logDiscEventAsReoptEvents :: + ArchConstraints arch => (Events.ReoptLogEvent arch -> IO ()) -> Macaw.AddrSymMap (Macaw.ArchAddrWidth arch) -> Macaw.DiscoveryEvent arch -> @@ -661,6 +675,7 @@ logDiscEventAsReoptEvents logger symMap evt = do logger $ Events.ReoptFunStepLog Events.Discovery (mkFunId fa) msg reoptRunDiscovery :: + ArchConstraints arch => Macaw.AddrSymMap (Macaw.ArchAddrWidth arch) -> IncCompM (Macaw.DiscoveryEvent arch) a a -> ReoptM arch r a @@ -1747,6 +1762,7 @@ headerTypeMap hdrAnn dynDepsTypeMap symAddrMap noretMap = do doDiscovery :: forall arch r. + ArchConstraints arch => -- | Header with hints for assisting typing. AnnDeclarations -> Elf.ElfHeaderInfo (Macaw.ArchAddrWidth arch) -> diff --git a/src/Reopt/ELFArchInfo.hs b/src/Reopt/ELFArchInfo.hs index a5495866..e21b622e 100644 --- a/src/Reopt/ELFArchInfo.hs +++ b/src/Reopt/ELFArchInfo.hs @@ -22,8 +22,8 @@ import Data.Vector qualified as V import Data.ByteString qualified as BS import Data.Macaw.Architecture.Info (ArchitectureInfo (..)) +import Data.Macaw.CFG qualified as Macaw import Data.Macaw.Utils.IncComp ( incCompLog, IncCompM) -import Data.Macaw.Discovery qualified as Macaw import Reopt.PLTParser as Reopt ( PLTInfo (..), extractPLTEntries, @@ -46,6 +46,7 @@ type ProcessPLTEntries w = data SomeArchitectureInfo w where SomeArch :: + Macaw.ArchConstraints arch => !(ArchitectureInfo arch) -> !(ProcessPLTEntries (Macaw.ArchAddrWidth arch)) -> SomeArchitectureInfo (Macaw.ArchAddrWidth arch) diff --git a/src/Reopt/Events.hs b/src/Reopt/Events.hs index 4b42dde9..d36f5d83 100644 --- a/src/Reopt/Events.hs +++ b/src/Reopt/Events.hs @@ -69,21 +69,10 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Parameterized.Some (Some (..)) import Data.Text (Text) -import Data.Text qualified as Text import Data.Void (Void) import Data.Word (Word64) import Numeric (showHex) -import Prettyprinter ( - Doc, - defaultLayoutOptions, - hang, - hsep, - indent, - layoutPretty, - pretty, - viaShow, - vsep, - ) +import Prettyprinter qualified as PP import Prettyprinter.Render.String (renderString) import Reopt.ExternalTools qualified as Ext import Reopt.FunUseMap (mkFunUseMap, totalFunUseSize) @@ -160,7 +149,7 @@ data DiscoveryError = DiscoveryError , discErrorBlockSize :: !Int , discErrorBlockInsnIndex :: !Int -- ^ Instruction index. - , discErrorMessage :: !Text + , discErrorMessage :: !(PP.Doc ()) } ------------------------------------------------------------------------------- @@ -391,7 +380,7 @@ printLogEvent event = do case s of Discovery -> unlines $ - [ printf " Block 0x%x: %s" (discErrorBlockAddr de) (Text.unpack (discErrorMessage de)) + [ printf " Block 0x%x: %s" (discErrorBlockAddr de) (show (discErrorMessage de)) | de <- e ] ++ [" Incomplete."] @@ -514,28 +503,28 @@ incStepError stepTag failureTag = Map.alter logFail stepTag logFail (Just m) = Just $ Map.alter incErr failureTag m -- otherwise just increment the particular failure -- | Render the registered failures in an indented list-style Doc. -renderAllFailures' :: forall a. (Num a, Show a) => StepErrorMap a -> Doc () -renderAllFailures' = vsep . map renderStepFailures . Map.toList +renderAllFailures' :: forall a. (Num a, Show a) => StepErrorMap a -> PP.Doc () +renderAllFailures' = PP.vsep . map renderStepFailures . Map.toList where - renderStepFailures :: (ReoptStepTag, Map ReoptErrorTag a) -> Doc () + renderStepFailures :: (ReoptStepTag, Map ReoptErrorTag a) -> PP.Doc () renderStepFailures (tag, failures) = let hdr = - hsep - [ viaShow $ stepCount failures - , pretty "failures during" - , pretty (ppReoptStepTag tag) <> pretty " step:" + PP.hsep + [ PP.viaShow $ stepCount failures + , PP.pretty "failures during" + , PP.pretty (ppReoptStepTag tag) <> PP.pretty " step:" ] - in hang 2 $ vsep $ hdr : map renderFailure (Map.toList failures) - renderFailure :: (ReoptErrorTag, a) -> Doc () - renderFailure (tag, cnt) = hsep [pretty $ show cnt, pretty $ ppReoptErrorTag tag] + in PP.hang 2 $ PP.vsep $ hdr : map renderFailure (Map.toList failures) + renderFailure :: (ReoptErrorTag, a) -> PP.Doc () + renderFailure (tag, cnt) = PP.hsep [PP.pretty $ show cnt, PP.pretty $ ppReoptErrorTag tag] stepCount :: Map ReoptErrorTag a -> a stepCount = foldl' (+) 0 . Map.elems renderAllFailures :: (Num a, Show a) => StepErrorMap a -> String renderAllFailures failures = renderString $ - layoutPretty defaultLayoutOptions $ - indent 2 $ + PP.layoutPretty PP.defaultLayoutOptions $ + PP.indent 2 $ renderAllFailures' failures ----------------------------------------------------------------------- diff --git a/src/Reopt/Events/Export.hs b/src/Reopt/Events/Export.hs index 355a0507..e08b3406 100644 --- a/src/Reopt/Events/Export.hs +++ b/src/Reopt/Events/Export.hs @@ -10,6 +10,8 @@ import Data.ByteString.Lazy qualified as BSL import Data.Text (Text) import Data.Word (Word64) import GHC.Generics (Generic) +import Prettyprinter qualified as PP +import Prettyprinter.Render.Text qualified as PP import Reopt.Events ( DiscoveryError ( discErrorBlockAddr, @@ -75,7 +77,10 @@ exportEvent h evt = let insn = discErrorBlockInsnIndex e let sz = discErrorBlockSize e let msg = discErrorMessage e - emitEvent h $ CFGError f b sz insn msg + emitEvent h $ + CFGError f b sz insn $ + PP.renderStrict $ + PP.layoutPretty PP.defaultLayoutOptions msg InvariantInference -> do pure () AnnotationGeneration -> do