Data.Macaw.Architecture.Info: Improve Classifier logging capabililty

This change does a few things to improve our ability to do logging
from the return classifiers. These help us collect tracing information
when intermediate failures occur in classifiers so we can diagnose the
failures.

* Adds some helper functions (tryClassifier, classifierLog,
  classifierGuard) to add non-failure logging messages to be carried in
  the classifier Monad

* Moves ArchitectureInfo's checkForReturnAddr and identifyReturn into
  Classifier monad

* Augments the PPC implementation of checkForReturnAddr (matchReturn) to
  do some additional logging when failures occur

base/src/Data/Macaw/Architecture/Info.hs

@@ -16,6 +16,9 @@ module Data.Macaw.Architecture.Info
   , runBlockClassifier
   , BlockClassifierContext(..)
   , Classifier(..)
+  , classifierLog
+  , tryClassifier
+  , classifierGuard
   , classifierName
   , liftClassifier
   , ParseContext(..)
@@ -23,10 +26,11 @@ module Data.Macaw.Architecture.Info
     -- * Unclassified blocks
   , module Data.Macaw.CFG.Block
   , rewriteBlock
+  , classifierLiftMaybe
   ) where
 
 import           Control.Applicative ( Alternative(..), liftA )
-import           Control.Monad ( ap )
+import           Control.Monad ( ap, guard )
 import qualified Control.Monad.Fail as MF
 import qualified Control.Monad.Reader as CMR
 import qualified Control.Monad.Trans as CMT
@@ -63,6 +67,32 @@ type ClassificationError = String
 data Classifier o = ClassifyFailed    [ClassificationError]
                   | ClassifySucceeded [ClassificationError] o
 
+-- | Log a message into the classifier's message collection. This
+-- is useful when tracing information needs to be stored alongside
+-- classifier errors.
+classifierLog :: String -> Classifier ()
+classifierLog msg = ClassifySucceeded [msg] ()
+
+-- | Given a Classifier, build a new unconditionally succeeding one that
+-- indicates whether the given classifier failed, but also carries all
+-- of its errors and tracing information.
+tryClassifier :: Classifier a -> Classifier Bool
+tryClassifier (ClassifyFailed msgs) = ClassifySucceeded msgs False
+tryClassifier (ClassifySucceeded msgs _) = ClassifySucceeded msgs True
+
+-- | A Classifier-specific version of 'guard' that emits a log message
+-- with the specified prefix if the guard expression is False (and also
+-- fails).
+classifierGuard :: String -> Bool -> Classifier ()
+classifierGuard _ True = return ()
+classifierGuard msg False = do
+    classifierLog $ "guard failed for: " <> msg
+    guard False
+
+classifierLiftMaybe :: Maybe a -> Classifier a
+classifierLiftMaybe Nothing = fail "classifierLiftMaybe: Nothing"
+classifierLiftMaybe (Just a) = return a
+
 -- | In the given context, set the name of the current classifier
 --
 -- This is used to improve the labels for each classifier failure
@@ -283,7 +313,7 @@ data ArchitectureInfo arch
      , checkForReturnAddr :: forall ids
                           .  RegState (ArchReg arch) (Value arch ids)
                           -> AbsProcessorState (ArchReg arch) ids
-                          -> Bool
+                          -> Classifier Bool
        -- ^ @checkForReturnAddr regs s@ returns true if the location
        -- where the return address is normally stored in regs when
        -- calling a function does indeed contain the abstract value
@@ -298,7 +328,7 @@ data ArchitectureInfo arch
                       .  Seq (Stmt arch ids)
                       -> RegState (ArchReg arch) (Value arch ids)
                       -> AbsProcessorState (ArchReg arch) ids
-                      -> Maybe (Seq (Stmt arch ids))
+                      -> Classifier (Seq (Stmt arch ids))
        -- ^ Identify returns to the classifier.
        --
        -- Given a list of statements and the final state of the registers, this

base/src/Data/Macaw/Discovery/Classifier.hs

@@ -279,11 +279,10 @@ returnClassifier = classifierName "Return" $ do
   bcc <- CMR.ask
   let ainfo = pctxArchInfo (classifierParseContext bcc)
   Info.withArchConstraints ainfo $ do
-    Just prevStmts <-
-      pure $ Info.identifyReturn ainfo
-                            (classifierStmts bcc)
-                            (classifierFinalRegState bcc)
-                            (classifierAbsState bcc)
+    prevStmts <- liftClassifier $ Info.identifyReturn ainfo
+                                    (classifierStmts bcc)
+                                    (classifierFinalRegState bcc)
+                                    (classifierAbsState bcc)
     pure $ Parsed.ParsedContents { Parsed.parsedNonterm = F.toList prevStmts
                               , Parsed.parsedTerm = Parsed.ParsedReturn (classifierFinalRegState bcc)
                               , Parsed.writtenCodeAddrs = classifierWrittenAddrs bcc
@@ -416,5 +415,7 @@ tailCallClassifier = classifierName "Tail call" $ do
     unless (o == 0) $
       fail "Expected stack height of 0"
     -- Return address is pushed
-    unless (Info.checkForReturnAddr ainfo (classifierFinalRegState bcc) (classifierAbsState bcc)) empty
+    isRet <- liftClassifier $ Info.checkForReturnAddr ainfo (classifierFinalRegState bcc) (classifierAbsState bcc)
+    unless isRet empty
+
     pure $! noreturnCallParsedContents bcc

macaw-aarch32/src/Data/Macaw/ARM.hs

@@ -12,6 +12,7 @@ module Data.Macaw.ARM
     )
     where
 
+import           Control.Monad ( guard )
 import           Control.Applicative ( (<|>) )
 import qualified Data.ElfEdit as EE
 import           Data.Macaw.ARM.Arch
@@ -48,8 +49,8 @@ arm_linux_info =
                         , MI.absEvalArchStmt = absEvalArchStmt
                         , MI.identifyCall = identifyCall
                         , MI.archCallParams = callParams preserveRegAcrossSyscall
-                        , MI.checkForReturnAddr = \r s -> isReturnValue s (r ^. MC.boundValue ARMReg.arm_LR)
-                        , MI.identifyReturn = identifyReturn
+                        , MI.checkForReturnAddr = \r s -> (guard $ isReturnValue s (r ^. MC.boundValue ARMReg.arm_LR)) >> return True
+                        , MI.identifyReturn = \x y z -> MI.classifierLiftMaybe $ identifyReturn x y z
                         , MI.rewriteArchFn = rewritePrimFn
                         , MI.rewriteArchStmt = rewriteStmt
                         , MI.rewriteArchTermStmt = rewriteTermStmt

macaw-ppc/src/Data/Macaw/PPC.hs

@@ -27,7 +27,6 @@ module Data.Macaw.PPC (
   ) where
 
 import           Control.Lens ( (^.) )
-import           Data.Maybe
 import           Data.Proxy ( Proxy(..) )
 
 import qualified Data.Macaw.Architecture.Info as MI
@@ -101,7 +100,7 @@ ppc64_linux_info binData =
                       , MI.absEvalArchFn = absEvalArchFn proxy
                       , MI.absEvalArchStmt = absEvalArchStmt proxy
                       , MI.identifyCall = identifyCall proxy
-                      , MI.checkForReturnAddr = \r s -> isJust $ matchReturn s (r ^. MC.boundValue R.PPC_LNK)
+                      , MI.checkForReturnAddr = \r s -> MI.tryClassifier $ matchReturn s (r ^. MC.boundValue R.PPC_LNK)
                       , MI.identifyReturn = identifyReturn proxy
                       , MI.rewriteArchFn = rewritePrimFn
                       , MI.rewriteArchStmt = rewriteStmt
@@ -127,7 +126,7 @@ ppc32_linux_info =
                       , MI.absEvalArchFn = absEvalArchFn proxy
                       , MI.absEvalArchStmt = absEvalArchStmt proxy
                       , MI.identifyCall = identifyCall proxy
-                      , MI.checkForReturnAddr = \r s -> isJust $ matchReturn s (r ^. MC.boundValue R.PPC_LNK)
+                      , MI.checkForReturnAddr = \r s -> MI.tryClassifier $ matchReturn s (r ^. MC.boundValue R.PPC_LNK)
                       , MI.identifyReturn = identifyReturn proxy
                       , MI.rewriteArchFn = rewritePrimFn
                       , MI.rewriteArchStmt = rewriteStmt

macaw-ppc/src/Data/Macaw/PPC/Identify.hs

@@ -9,10 +9,10 @@ module Data.Macaw.PPC.Identify
 where
 
 import           Control.Lens ( (^.) )
-import           Control.Monad ( guard )
 import           Data.Parameterized.Some ( Some(..) )
 import qualified Data.Sequence as Seq
 
+import qualified Data.Macaw.Architecture.Info as MI
 import qualified Data.Macaw.AbsDomain.AbsState as MA
 import qualified Data.Macaw.CFG as MC
 import qualified Data.Macaw.Discovery.AbsEval as DE

x86/src/Data/Macaw/X86.hs

@@ -532,11 +532,11 @@ checkForReturnAddrX86 absState
 identifyX86Return :: Seq (Stmt X86_64 ids)
                   -> RegState X86Reg (Value X86_64 ids)
                   -> AbsProcessorState X86Reg ids
-                  -> Maybe (Seq (Stmt X86_64 ids))
+                  -> Classifier (Seq (Stmt X86_64 ids))
 identifyX86Return stmts s finalRegSt8 =
   case transferValue finalRegSt8 (s^.boundValue ip_reg) of
-    ReturnAddr -> Just stmts
-    _ -> Nothing
+    ReturnAddr -> return stmts
+    _ -> return mempty
 
 freeBSD_syscallPersonality :: SyscallPersonality
 freeBSD_syscallPersonality =
@@ -593,7 +593,7 @@ x86_64_info preservePred =
                    , absEvalArchStmt = \s _ -> s
                    , identifyCall = identifyX86Call
                    , archCallParams = x86_64CallParams
-                   , checkForReturnAddr = \_ s -> checkForReturnAddrX86 s
+                   , checkForReturnAddr = \_ s -> guard $ checkForReturnAddrX86 s
                    , identifyReturn = identifyX86Return
                    , rewriteArchFn = rewriteX86PrimFn
                    , rewriteArchStmt = rewriteX86Stmt