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

@@ -41,6 +41,7 @@ import Data.Macaw.Discovery (
   memory,
   ppDiscoveryStateBlocks,
  )
+import Data.Macaw.X86 ()
 import Data.Maybe (
   fromMaybe,
   isJust,

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) ->

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)

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
 
 -----------------------------------------------------------------------

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