commit dd561dc3aeea8b244fe48229f71e8d6033499e75
parent f6057154d6ff7290f382fba8a9a7cec97af509a8
Author: Jared Tobin <jared@jtobin.io>
Date: Tue, 27 Oct 2026 11:19:03 +0400
record, diff: instructions outside the contract, reported apart
record --contract writes the watch list for the objects the program
loads that --object names, and appends the guest's ISA and the
contract to its dump. diff reports an instruction outside the
contract run equally often on other operands under outside, apart
from the origins, with how many such instructions ran
(vestigia/diff-v4), and refuses runs recorded under other contracts.
Diffstat:
| M | app/Main.hs | | | 145 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------- |
| M | lib/Vestigia/Diff.hs | | | 188 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------- |
| M | test/Main.hs | | | 120 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
3 files changed, 403 insertions(+), 50 deletions(-)
diff --git a/app/Main.hs b/app/Main.hs
@@ -15,6 +15,7 @@ module Main (
import Control.Exception (IOException, try)
import Control.Monad (unless, when)
+import qualified Data.List as L
import qualified Data.ByteString as BS
import Data.Char (toUpper)
import qualified Data.Map.Strict as M
@@ -28,22 +29,26 @@ import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
import qualified Data.Text.IO as TIO
import System.Directory
- (createDirectoryIfMissing, doesDirectoryExist, doesFileExist,
- getTemporaryDirectory, removeFile)
+ (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,
+ doesFileExist, getTemporaryDirectory, removeFile)
import System.Environment (getArgs, getEnvironment, lookupEnv)
import System.Exit (ExitCode(..), exitWith)
import System.FilePath (takeFileName, (</>))
import Text.Read (readMaybe)
import System.IO
(IOMode(..), hClose, hPutStrLn, openTempFile, stderr, withBinaryFile)
-import System.Process (proc, waitForProcess, withCreateProcess)
+import System.Process
+ (proc, readCreateProcessWithExitCode, waitForProcess, withCreateProcess)
import qualified System.Process as P
import Paths_vestigia (version)
+import Vestigia.Contract
+ (Contract(..), Line, contractIsa, contractName, readContract,
+ readDisassembly, watchSection)
import Vestigia.Diff
(Dump(..), Kind(..), Named(..), Run(..), diffDesigned, divergenceJson,
- divergenceSummary, dvCallers, dvOrigins, inObject, inOffset, inPc,
- layoutApart, readDump, restrictTo, runApart)
+ divergenceSummary, dvCallers, dvOrigins, dvOutside, inObject, inOffset,
+ inPc, layoutApart, readDump, restrictTo, runApart)
import Vestigia.Json (encode)
import Vestigia.Layout (fixLayout)
import Vestigia.Memcheck (Memcheck, readMemcheck)
@@ -62,6 +67,8 @@ data Opts = Opts {
, oObjects :: ![T.Text]
, oControls :: ![FilePath]
, oDesigned :: ![FilePath]
+ , oContract :: !(Maybe T.Text)
+ , oObjdump :: !(Maybe FilePath)
}
main :: IO ()
@@ -96,6 +103,7 @@ usage e = do
\[--object TEXT]... -- PROGRAM [ARG...]"
, " vestigia read [--out FILE] [--object TEXT]... RUN..."
, " vestigia record [--qemu PATH] [--plugin PATH] --dump FILE \
+ \[--contract NAME [--objdump PATH] [--object TEXT]...] \
\-- PROGRAM [ARG...]"
, " vestigia diff [--out FILE] [--addr2line PATH] \
\[--object TEXT]... [--control DUMP]... [--designed DUMP]... \
@@ -112,8 +120,15 @@ usage e = do
, "record executes PROGRAM under QEMU with vestigia's plugin and"
, "dumps its leakage trace per instruction, with how it was run;"
, "diff compares dumps of runs that differ only in a secret and"
- , "reports where they diverge (vestigia/diff-v3), naming sources"
+ , "reports where they diverge (vestigia/diff-v4), naming sources"
, "with addr2line."
+ , "--contract (arm-dit or intel-doitm, the program's ISA's) has"
+ , "record also fingerprint the operands of every instruction"
+ , "outside that data-independent-timing contract, in the objects"
+ , "the program loads whose path contains an --object TEXT (all,"
+ , "with none), read with objdump (--objdump, else"
+ , "$VESTIGIA_OBJDUMP, else llvm-objdump); diff reports those whose"
+ , "operands differed beside the origins."
, "--object keeps origins in objects whose path contains TEXT;"
, "--control names a run repeating the first run's secret, and"
, "what differs in it is unsteady, not an origin."
@@ -127,7 +142,7 @@ usage e = do
-- options before the program; "--" ends them
options :: [String] -> Either String (Opts, [String])
options = go (Opts Nothing Nothing Nothing Nothing Nothing Nothing
- Nothing [] [] [])
+ Nothing [] [] [] Nothing Nothing)
where
go o xs = case xs of
("--" : rest) -> Right (o, rest)
@@ -144,6 +159,8 @@ options = go (Opts Nothing Nothing Nothing Nothing Nothing Nothing
go o { oControls = oControls o <> [ p ] } rest
("--designed" : p : rest) ->
go o { oDesigned = oDesigned o <> [ p ] } rest
+ ("--contract" : c : rest) -> go o { oContract = Just (T.pack c) } rest
+ ("--objdump" : p : rest) -> go o { oObjdump = Just p } rest
(x : _) | take 2 x == "--" -> Left ("unknown option: " <> x)
_ -> Right (o, xs)
@@ -303,6 +320,16 @@ record o prog progArgs = do
qemu <- tool (oQemu o) ("VESTIGIA_QEMU_" <> fmap toUpper isa)
("qemu-" <> isa)
plugin <- tool (oPlugin o) "VESTIGIA_PLUGIN" "libvestigia-qemu.so"
+ -- under a contract, the instructions outside it in the objects
+ -- under audit, for the plugin to watch
+ contract <- traverse (\name -> case readContract name of
+ Just c | contractIsa c == isa -> pure c
+ | otherwise -> refuseRecord (T.unpack name <> " speaks to "
+ <> contractIsa c <> ", and " <> prog <> " is " <> isa)
+ Nothing -> refuseRecord ("no contract named " <> T.unpack name
+ <> "; arm-dit and intel-doitm are known"))
+ (oContract o)
+ watch <- traverse (\c -> watchList o qemu c prog progArgs) contract
-- QEMU maps the guest's libraries and heap in its own address
-- space, wherever its own allocations leave room, and those vary
-- with how its threads run: a second malloc arena, or a large block
@@ -322,10 +349,13 @@ record o prog progArgs = do
r <- try (withCreateProcess
((proc qemu (guest
<> [ "-seed", "0"
- , "-plugin", plugin <> ",out=" <> dump, prog ]
+ , "-plugin", plugin <> ",out=" <> dump
+ <> maybe "" (",watch=" <>) watch
+ , prog ]
<> progArgs))
{ P.env = Just ((tunables, host) : others) })
(\_ _ _ ph -> waitForProcess ph))
+ for_ watch removeFile
case r of
Left e -> do
hPutStrLn stderr ("vestigia: cannot run " <> qemu <> ": "
@@ -336,9 +366,80 @@ record o prog progArgs = do
-- in the secret alone from runs laid out apart: the guest's
-- environment is QEMU's, with its own tunables restored
appendRun dump (prog : progArgs)
- (others <> [ (tunables, v) | Just v <- [ own ] ]) c
+ (others <> [ (tunables, v) | Just v <- [ own ] ]) c isa contract
exitWith c
+refuseRecord :: String -> IO a
+refuseRecord e = do
+ hPutStrLn stderr ("vestigia: " <> e)
+ exitWith (ExitFailure 2)
+
+-- the plugin's watch list under a contract, written to a temporary
+-- file: every instruction outside it in the objects the program loads
+-- (and the program's own) whose path contains an --object text, all
+-- of them with none
+watchList :: Opts -> FilePath -> Contract -> FilePath -> [String]
+ -> IO FilePath
+watchList o qemu c prog progArgs = do
+ objdump <- tool (oObjdump o) "VESTIGIA_OBJDUMP" "llvm-objdump"
+ loaded <- loadedObjects qemu prog progArgs
+ objects <- fmap L.nub (traverse canonicalizePath (prog : loaded))
+ let kept = [ p | p <- objects
+ , null (oObjects o)
+ || any (`T.isInfixOf` T.pack p) (oObjects o) ]
+ sections <- traverse (\p -> do
+ ls <- disassemble objdump c p
+ pure (watchSection c p ls))
+ kept
+ tmp <- getTemporaryDirectory
+ (path, h) <- openTempFile tmp "vestigia.watch"
+ hClose h
+ TIO.writeFile path (T.concat sections)
+ pure path
+
+-- the shared objects a program loads, as its dynamic loader resolves
+-- them, run under QEMU so that any ISA's are found
+loadedObjects :: FilePath -> FilePath -> [String] -> IO [FilePath]
+loadedObjects qemu prog progArgs = do
+ r <- try (readCreateProcessWithExitCode
+ (proc qemu ([ "-E", "LD_TRACE_LOADED_OBJECTS=1", prog ]
+ <> progArgs)) "")
+ case r of
+ Left e -> refuseRecord ("cannot run " <> qemu <> ": "
+ <> show (e :: IOException))
+ Right (ExitSuccess, out, _) -> pure (concatMap object (lines out))
+ Right (ExitFailure n, _, err) -> refuseRecord ("the loader could not \
+ \list what " <> prog <> " loads (exit " <> show n <> "): " <> err)
+ where
+ -- "\tNAME => PATH (0x...)" or "\tPATH (0x...)"
+ object l = case words l of
+ (_ : "=>" : p@('/' : _) : _) -> [ p ]
+ (p@('/' : _) : _) -> [ p ]
+ _ -> []
+
+-- an object's instructions, its executable sections disassembled
+-- whole: GHC's LLVM backend gives its code the type of data, which a
+-- disassembly by symbol would print as bytes
+disassemble :: FilePath -> Contract -> FilePath -> IO [Line]
+disassemble objdump c obj = do
+ headers <- objdumped [ "--section-headers", obj ]
+ let sections = [ name | l <- lines headers
+ , (_ : name : _ : _ : kinds) <- [ words l ]
+ , "TEXT" `elem` kinds ]
+ out <- objdumped ([ "-D" ] <> fmap ("--section=" <>) sections
+ <> [ "-M" | c == IntelDoitm ] <> [ "intel" | c == IntelDoitm ]
+ <> [ obj ])
+ pure (readDisassembly (T.pack out))
+ where
+ objdumped args = do
+ r <- try (readCreateProcessWithExitCode (proc objdump args) "")
+ case r of
+ Right (ExitSuccess, out, _) -> pure out
+ Right (ExitFailure n, _, err) -> refuseRecord (objdump <> " "
+ <> unwords args <> " failed (exit " <> show n <> "): " <> err)
+ Left e -> refuseRecord ("cannot run " <> objdump <> ": "
+ <> show (e :: IOException))
+
-- the architecture an ELF program is built for, as QEMU names its
-- user-mode emulators: the header's machine, at byte 18
machineOf :: FilePath -> IO String
@@ -358,10 +459,11 @@ machineOf prog = do
-- append a run's record to its dump (Vestigia.Diff.readDump): its
-- arguments' bytes, its environment's variables and the bytes they
--- take, and its exit status
+-- take, its exit status, the guest's ISA, and any contract it was
+-- recorded under
appendRun :: FilePath -> [String] -> [(String, String)] -> ExitCode
- -> IO ()
-appendRun dump args env code = do
+ -> String -> Maybe Contract -> IO ()
+appendRun dump args env code isa contract = do
enc <- getFileSystemEncoding
let bytes s = GF.withCStringLen enc s BS.packCStringLen
as <- traverse bytes args
@@ -371,7 +473,9 @@ appendRun dump args env code = do
| a <- as ]
<> [ "N " <> showHex (length es) "" <> " "
<> showHex (sum (fmap ((+ 1) . BS.length) es)) ""
- , "X " <> show (exitStatus code) ]
+ , "X " <> show (exitStatus code)
+ , "M " <> isa ]
+ <> [ "G " <> T.unpack (contractName c) | Just c <- [ contract ] ]
where
byte w = case showHex w "" of
[ d ] -> [ '0', d ]
@@ -405,6 +509,15 @@ diff o paths = do
refuse (p <> " is a control, but does not repeat the \
\arguments of " <> p0 <> ", the run it controls")
[] -> pure ()
+ -- runs recorded under other contracts watched other instructions
+ case zip (paths <> oDesigned o <> oControls o)
+ (dumps <> designed <> controls) of
+ ((p0, first) : rest) -> for_ rest $ \(p, d) ->
+ when (dpContract d /= dpContract first || dpIsa d /= dpIsa first) $
+ refuse (p <> " was recorded for another ISA or under another \
+ \contract than " <> p0 <> "; runs compared must watch the \
+ \same instructions")
+ [] -> pure ()
-- runs laid out apart differ wherever they touch memory, not by
-- the secret: such runs are refused, not compared
case zip paths dumps of
@@ -424,11 +537,11 @@ diff o paths = do
[] -> pure ()
let dv = restrictTo (oObjects o)
(diffDesigned controls dumps designed)
+ let sites = fmap snd (dvOrigins dv) <> dvOutside dv
places <- symbolize addr2line $
- [ (obj, inOffset i) | (_, i) <- dvOrigins dv
- , Just obj <- [ inObject i ] ]
+ [ (obj, inOffset i) | i <- sites, Just obj <- [ inObject i ] ]
-- the calls that reached each origin
- <> [ (obj, a) | (_, i) <- dvOrigins dv
+ <> [ (obj, a) | i <- sites
, Just (stacks, _) <- [ M.lookup (inPc i) (dvCallers dv) ]
, calls <- stacks, (Just obj, a) <- calls ]
let doc = encode (divergenceJson (T.pack (showVersion version))
diff --git a/lib/Vestigia/Diff.hs b/lib/Vestigia/Diff.hs
@@ -63,6 +63,13 @@
-- runs that never reached it. Whether two runs
-- that differed there both had their secrets accepted is the
-- reader's to say, from what each run returned.
+--
+-- Runs recorded under a data-independent-timing contract
+-- (Vestigia.Contract) also fingerprint the operands of every
+-- instruction outside it. One run equally often on other operands
+-- in some declared run is outside the contract on the secret: not an
+-- origin, since the contract says nothing either way of its time,
+-- but reported beside them, as is how many such instructions ran.
module Vestigia.Diff (
Insn(..)
@@ -96,6 +103,7 @@ import qualified Data.Text.Encoding.Error as TEE
import Numeric (readHex, showHex)
import Text.Read (readMaybe)
+import Vestigia.Contract (contractSource, readContract)
import Vestigia.Json
import Vestigia.Symbol (Place(..))
@@ -137,6 +145,15 @@ data Dump = Dump {
, dpContexts :: !(M.Map Integer (Integer, Integer))
, dpCallers :: !(M.Map Integer (Bool, [Integer]))
, dpRun :: !(Maybe Run)
+ -- | the operands, fingerprinted, of the instructions outside the
+ -- contract the run was recorded under
+ , dpOutside :: !(M.Map Integer T.Text)
+ -- | the text of each instruction the watch list named
+ , dpTexts :: !(M.Map Integer T.Text)
+ -- | the guest's ISA, and the contract, as `vestigia record`
+ -- appends them
+ , dpIsa :: !(Maybe T.Text)
+ , dpContract :: !(Maybe T.Text)
} deriving (Eq, Show)
-- | Read a plugin dump. A dump in which no instruction ran records
@@ -147,11 +164,13 @@ data Dump = Dump {
-- program's own. The record `vestigia record` appends (an @A@ line
-- per argument, its bytes in hex; @N@, the environment's variables
-- and bytes, in hex; @X@, the exit status, in decimal) is read
--- whole or not at all.
+-- whole or not at all. Beside it, @M@ names the guest's ISA and @G@
+-- the contract the run was recorded under.
readDump :: T.Text -> Either String Dump
readDump t = do
d <- foldM line (Dump M.empty M.empty S.empty M.empty M.empty M.empty
- Nothing, [], Nothing, Nothing) (T.lines t)
+ Nothing M.empty M.empty Nothing Nothing, [], Nothing
+ , Nothing) (T.lines t)
let (dump, as, env, st) = d
cx = dpContexts dump
unless (any ((> 0) . inCount) (M.elems (dpInsns dump))) $
@@ -187,6 +206,16 @@ readDump t = do
k <- unhex pc
pure (d { dpOperands = M.insert k fp (dpOperands d) }, as, env
, st)
+ [ "U", pc, fp ] -> do
+ k <- unhex pc
+ pure (d { dpOutside = M.insert k fp (dpOutside d) }, as, env
+ , st)
+ ("W" : pc : text@(_ : _)) -> do
+ k <- unhex pc
+ pure (d { dpTexts = M.insert k (T.unwords text) (dpTexts d) }, as
+ , env, st)
+ [ "M", isa ] -> pure (d { dpIsa = Just isa }, as, env, st)
+ [ "G", c ] -> pure (d { dpContract = Just c }, as, env, st)
[ "C", c, caller, call ] -> do
v <- (,) <$> unhex caller <*> unhex call
k <- unhex c
@@ -324,6 +353,20 @@ data Divergence = Divergence {
-- in the declared and designed runs, at most 16 of them, and
-- whether there were more than those
, dvCallers :: !(M.Map Integer ([[(Maybe T.Text, Integer)]], Bool))
+ -- | the instructions outside the contract run equally often in
+ -- every declared run, on other operands in one, each with the
+ -- runs alike there and those that never ran it
+ , dvOutside :: ![Insn]
+ , dvOutsideBehaviour :: !(M.Map Integer ([[Int]], [Int]))
+ -- | the instructions outside the contract some run executed, by
+ -- object
+ , dvWatched :: !(M.Map T.Text (S.Set Integer))
+ -- | the text of each instruction the watch list named
+ , dvTexts :: !(M.Map Integer T.Text)
+ -- | the guest's ISA and the contract, as the declared runs name
+ -- them
+ , dvIsa :: !(Maybe T.Text)
+ , dvContract :: !(Maybe T.Text)
} deriving (Eq, Show)
-- | Compare runs, uncontrolled.
@@ -361,9 +404,36 @@ diffDesigned cs ds xs = Divergence {
, inCount i > 0
, Just obj <- [ inObject i ] ]
, dvCallers = M.fromList
- [ (inPc i, callersAt (inPc i)) | (_, i) <- origins ]
+ [ (inPc i, callersAt (inPc i))
+ | i <- fmap snd origins <> outside ]
+ , dvOutside = outside
+ , dvOutsideBehaviour = M.fromList
+ [ ( inPc i
+ , ( classes (==) [ (k, M.lookup (inPc i) (dpOutside d))
+ | (k, d) <- ranIn' ds (inPc i) ]
+ , [ k | (k, d) <- zip [ 0 .. ] ds
+ , maybe True ((== 0) . inCount)
+ (M.lookup (inPc i) (dpInsns d)) ] ) )
+ | i <- outside ]
+ , dvWatched = M.fromListWith S.union
+ [ (obj, S.singleton (inOffset i))
+ | d <- ds <> xs <> cs
+ , pc <- M.keys (dpOutside d)
+ , Just i <- [ M.lookup pc (dpInsns d) ]
+ , inCount i > 0
+ , Just obj <- [ inObject i ] ]
+ , dvTexts = M.unions (fmap dpTexts (ds <> xs <> cs))
+ , dvIsa = case ds of
+ (d : _) -> dpIsa d
+ [] -> Nothing
+ , dvContract = case ds of
+ (d : _) -> dpContract d
+ [] -> Nothing
}
where
+ ranIn' rs pc = [ (k, d) | (k, d) <- zip [ 0 .. ] rs
+ , Just i <- [ M.lookup pc (dpInsns d) ]
+ , inCount i > 0 ]
callersAt pc =
let found = [ (partial, fmap (callsOf d) ks)
| d <- runs
@@ -384,7 +454,8 @@ diffDesigned cs ds xs = Divergence {
ta = M.lookup pc (dpTransfers a)
tb = M.lookup pc (dpTransfers b)
, fmap sig ia /= fmap sig ib || ta /= tb
- || M.lookup pc (dpOperands a) /= M.lookup pc (dpOperands b) ]
+ || M.lookup pc (dpOperands a) /= M.lookup pc (dpOperands b)
+ || M.lookup pc (dpOutside a) /= M.lookup pc (dpOutside b) ]
sig i = (inCount i, inFingerprint i, inOrder i)
origins = [ o | o@(_, i) <- controls <> addresses <> operands
@@ -467,10 +538,11 @@ diffDesigned cs ds xs = Divergence {
-- the address and operand origins
dataPcs = S.fromList [ inPc i | (_, i) <- addresses <> operands ]
downstream =
- (((pcs `S.difference` steady)
- `S.union` (divergentPcs `S.intersection` returns))
- `S.difference` controlPcs)
- `S.difference` dataPcs
+ ((((pcs `S.difference` steady)
+ `S.union` (divergentPcs `S.intersection` returns))
+ `S.difference` controlPcs)
+ `S.difference` dataPcs)
+ `S.difference` S.fromList (fmap inPc outside)
controls =
[ (ControlOrigin, i)
@@ -486,6 +558,20 @@ diffDesigned cs ds xs = Divergence {
, Just i <- [ firstInsn pc ]
, inAccesses i > 0 ]
+ -- an instruction outside the contract run equally often in
+ -- every declared run, on other operands in one, where it is not
+ -- an origin already
+ outside =
+ [ i
+ | pc <- S.toAscList steadyDeclared
+ , not (pc `S.member` unsteady)
+ , not (pc `S.member` controlPcs)
+ , not (pc `S.member` dataPcs)
+ , let fps = [ M.lookup pc (dpOutside d) | d <- ds ]
+ , any (/= Nothing) fps
+ , not (alike fps)
+ , Just i <- [ firstInsn pc ] ]
+
-- a division run equally often in every declared run, on other
-- operands in one
operands =
@@ -506,6 +592,9 @@ restrictTo ps dv
, dvDownstream = filter (inside . inObject) (dvDownstream dv)
, dvExecuted = M.filterWithKey (\o _ -> inside (Just o))
(dvExecuted dv)
+ , dvOutside = filter (inside . inObject) (dvOutside dv)
+ , dvWatched = M.filterWithKey (\o _ -> inside (Just o))
+ (dvWatched dv)
}
where
inside mo = case mo of
@@ -518,19 +607,29 @@ originText o = case o of
AddressOrigin -> "address"
OperandOrigin -> "operand"
--- | The report: @vestigia/diff-v3@. Runs are given the declared,
+-- | The report: @vestigia/diff-v4@. Runs are given the declared,
-- then the designed, then the controls, and an origin names the
-- runs alike at it by the first two. An origin's stacks are its own
-- frames then its calls', innermost first, each frame with the
-- object and address of the instruction it names, as memcheck's
--- are in a taint report.
+-- are in a taint report. The ISA and contract the runs were
+-- recorded under head it; the instructions outside the contract
+-- whose operands differed are given as origins are, and those that
+-- ran, by object, as what was executed is.
divergenceJson
:: T.Text -> [Named] -> M.Map (T.Text, Integer) [Place] -> Divergence
-> Value
divergenceJson version runs places dv = Object
- [ ("schema", String "vestigia/diff-v3")
+ [ ("schema", String "vestigia/diff-v4")
, ("tool", Object [ ("name", String "vestigia")
, ("version", String version) ])
+ , ("isa", maybe Null String (dvIsa dv))
+ , ("contract", case dvContract dv of
+ Just n -> Object
+ [ ("name", String n)
+ , ("source", maybe Null (String . contractSource)
+ (readContract n)) ]
+ Nothing -> Null)
, ("runs", Array
[ Object
[ ("name", String (nmName r))
@@ -547,28 +646,18 @@ divergenceJson version runs places dv = Object
, ("operand", count OperandOrigin)
, ("downstream", Number (toInteger (length (dvDownstream dv))))
, ("unsteady", Number (toInteger (length (dvUnsteady dv))))
+ , ("outside", Number (toInteger (length (dvOutside dv))))
+ , ("watched", Number (toInteger (sum (fmap S.size
+ (M.elems (dvWatched dv))))))
])
, ("origins", Array
- [ Object $
- [ ("class", String (originText o))
- , ("pc", String (hex (inPc i)))
- , ("object", maybe Null String (inObject i))
- , ("offset", String (hex (inOffset i)))
- , ("count", Number (inCount i))
- , ("frames", Array (fmap placeJson (placesOf i)))
- , ("stacks", Array
- [ Array (located (inObject i, inOffset i)
- <> concatMap located calls)
- | calls <- stacks ])
- , ("partial", Bool partial)
- , ("groups", Array (fmap (Array . fmap named) groups))
- , ("absent", Array (fmap named absent))
- ]
- | (o, i) <- dvOrigins dv
- , let (groups, absent) = M.findWithDefault ([], []) (o, inPc i)
- (dvBehaviour dv)
- (stacks, partial) = M.findWithDefault ([], False) (inPc i)
- (dvCallers dv) ])
+ [ site (originText o) i
+ (M.findWithDefault ([], []) (o, inPc i) (dvBehaviour dv))
+ | (o, i) <- dvOrigins dv ])
+ , ("outside", Array
+ [ site "outside" i
+ (M.findWithDefault ([], []) (inPc i) (dvOutsideBehaviour dv))
+ | i <- dvOutside dv ])
, ("downstream", Object
[ (obj, Array (fmap (String . hex) (S.toAscList offs)))
| (obj, offs) <- M.toList (M.fromListWith S.union
@@ -578,8 +667,31 @@ divergenceJson version runs places dv = Object
, ("executed", Object
[ (o, Array (fmap (String . hex) (S.toAscList xs)))
| (o, xs) <- M.toList (dvExecuted dv) ])
+ , ("watched", Object
+ [ (o, Array (fmap (String . hex) (S.toAscList xs)))
+ | (o, xs) <- M.toList (dvWatched dv) ])
]
where
+ site cls i (groups, absent) =
+ let (stacks, partial) = M.findWithDefault ([], False) (inPc i)
+ (dvCallers dv)
+ in Object
+ [ ("class", String cls)
+ , ("pc", String (hex (inPc i)))
+ , ("object", maybe Null String (inObject i))
+ , ("offset", String (hex (inOffset i)))
+ , ("count", Number (inCount i))
+ , ("instruction", maybe Null String
+ (M.lookup (inPc i) (dvTexts dv)))
+ , ("frames", Array (fmap placeJson (placesOf i)))
+ , ("stacks", Array
+ [ Array (located (inObject i, inOffset i)
+ <> concatMap located calls)
+ | calls <- stacks ])
+ , ("partial", Bool partial)
+ , ("groups", Array (fmap (Array . fmap named) groups))
+ , ("absent", Array (fmap named absent))
+ ]
names = [ nmName r | r <- runs, nmKind r /= ControlRun ]
kindText k = case k of
DeclaredRun -> "declared"
@@ -623,12 +735,13 @@ divergenceSummary
:: M.Map (T.Text, Integer) [Place] -> Divergence -> T.Text
divergenceSummary places dv = T.unlines $
[ T.intercalate " "
- [ originText o
+ [ cls
, hex (inOffset i)
, maybe "?" id (plFunction =<< innermost i)
, maybe "?" location (innermost i)
, maybe "-" base (inObject i) ]
- | (o, i) <- dvOrigins dv ]
+ | (cls, i) <- [ (originText o, i) | (o, i) <- dvOrigins dv ]
+ <> [ ("outside", i) | i <- dvOutside dv ] ]
<> [ T.pack (show (length (dvOrigins dv))) <> " origin(s) over "
<> T.pack (show (dvRuns dv)) <> " run(s)"
<> (if dvDesigned dv == 0 then ""
@@ -638,8 +751,15 @@ divergenceSummary places dv = T.unlines $
<> " instruction(s) downstream; "
<> T.pack (show (length (dvUnsteady dv)))
<> " unsteady over " <> T.pack (show (dvControls dv))
- <> " control(s)" ]
+ <> " control(s)"
+ <> maybe ""
+ (\c -> "; " <> T.pack (show watched)
+ <> " instruction(s) outside " <> c <> " ran, "
+ <> T.pack (show (length (dvOutside dv)))
+ <> " on operands that differed")
+ (dvContract dv) ]
where
+ watched = sum (fmap S.size (M.elems (dvWatched dv)))
innermost i = case inObject i of
Just obj -> case M.findWithDefault [] (obj, inOffset i) places of
(p : _) -> Just p
diff --git a/test/Main.hs b/test/Main.hs
@@ -12,6 +12,7 @@ import qualified Data.Text.Encoding as TE
import Test.Tasty
import Test.Tasty.HUnit
+import Vestigia.Contract
import Vestigia.Diff
import Vestigia.Json
import Vestigia.Memcheck
@@ -24,6 +25,7 @@ main = defaultMain $ testGroup "vestigia"
[ xmlTests
, memcheckTests
, traceTests
+ , contractTests
, diffTests
, symbolTests
, jsonTests
@@ -142,6 +144,94 @@ traceTests = testGroup "trace"
fmap fst (trUnrelated tr) @?= [ 0 ]
]
+contractTests :: TestTree
+contractTests = testGroup "contract"
+ [ testCase "AArch64: a division, and what DIT covers" $ do
+ classify ArmDit (word 0x1ac20820) @?= Division -- udiv w0
+ classify ArmDit (word 0x9ac20c20) @?= Division -- sdiv x0
+ classify ArmDit (word 0x8b020020) @?= Inside -- add x0
+ classify ArmDit (word 0x9bc27c20) @?= Inside -- umulh x0
+ classify ArmDit (word 0xdac00c20) @?= Inside -- rev x0
+ classify ArmDit (word 0xd65f03c0) @?= Excluded -- ret
+ classify ArmDit (word 0x90000420) @?= Excluded -- adrp x0
+
+ , testCase "AArch64: outside DIT, with the registers read" $ do
+ -- fdiv d0, d1, d2
+ classify ArmDit (word 0x1e621820)
+ @?= Watched [ Register "v1" 0 64, Register "v2" 0 64 ] False
+ -- fmov x0, d1
+ classify ArmDit (word 0x9e660020)
+ @?= Watched [ Register "v1" 0 64 ] False
+ -- fadd v0.4s, v1.4s, v2.4s, and its 64-bit arrangement
+ classify ArmDit (word 0x4e22d420)
+ @?= Watched [ Register "v1" 0 128, Register "v2" 0 128 ] False
+ classify ArmDit (word 0x0e22d420)
+ @?= Watched [ Register "v1" 0 64, Register "v2" 0 64 ] False
+
+ , testCase "x86_64: a division, and what DOITM covers" $ do
+ classify IntelDoitm (x86 [ 0x48, 0xf7, 0xf6 ] "div" "rsi")
+ @?= Division
+ classify IntelDoitm (x86 [ 0xc1, 0xc0, 0x07 ] "rol" "eax, 0x7")
+ @?= Inside
+ classify IntelDoitm (x86 [ 0x48, 0x0f, 0xc8 ] "bswap" "rax")
+ @?= Inside
+ classify IntelDoitm (x86 [ 0x48, 0x0f, 0x44, 0xc3 ] "cmove"
+ "rax, rbx") @?= Inside
+ classify IntelDoitm (x86 [ 0x48, 0xb8, 1, 0, 0, 0, 0, 0, 0, 0 ]
+ "movabs" "rax, 0x1") @?= Inside
+ classify IntelDoitm (x86 [ 0xc5, 0xf5, 0xd4, 0xc2 ] "vpaddq"
+ "ymm0, ymm1, ymm2") @?= Inside
+ classify IntelDoitm (x86 [ 0x75, 0x02 ] "jne" "0x10") @?= Excluded
+ classify IntelDoitm (x86 [ 0x90 ] "nop" "") @?= Excluded
+
+ , testCase "x86_64: outside DOITM, with the registers read" $ do
+ -- popcnt only writes its destination
+ classify IntelDoitm (x86 [ 0xf3, 0x48, 0x0f, 0xb8, 0xc3 ] "popcnt"
+ "rax, rbx")
+ @?= Watched [ Register "rbx" 0 64 ] False
+ classify IntelDoitm (x86 [ 0x92 ] "xchg" "eax, edx")
+ @?= Watched [ Register "rax" 0 32, Register "rdx" 0 32 ] False
+ -- a legacy SSE division reads its destination too
+ classify IntelDoitm (x86 [ 0xf2, 0x0f, 0x5e, 0xc1 ] "divsd"
+ "xmm0, xmm1")
+ @?= Watched [ Register "xmm0" 0 128, Register "xmm1" 0 128 ] False
+ classify IntelDoitm (x86 [ 0x98 ] "cwde" "")
+ @?= Watched [ Register "rax" 0 16 ] False
+ -- a memory operand's registers are its address's, not its data
+ classify IntelDoitm (x86 [ 0x0f, 0x54, 0x07 ] "andps"
+ "xmm0, xmmword ptr [rdi]")
+ @?= Watched [ Register "xmm0" 0 128 ] True
+
+ , testCase "llvm-objdump's lines are read" $ do
+ readDisassembly (T.unlines
+ [ "0000000000001000 <f>:"
+ , " 1000: 48 89 e5 \tmov\trbp, rsp"
+ , " 1003: f3 48 ab \trep\t\tstosq\tqword \
+ \ptr es:[rdi], rax"
+ , " 1006: 48 8b 05 4d b5 06 00 \tmov\trax, qword ptr \
+ \[rip + 0x6b54d] # 0x86d58 <x>"
+ , "\t\t..."
+ , " 1b824: 9112a000 \tadd\tx0, x0, #0x4a8" ])
+ @?= [ Line 0x1000 [ 0x48, 0x89, 0xe5 ] [] "mov" "rbp, rsp"
+ , Line 0x1003 [ 0xf3, 0x48, 0xab ] [ "rep" ] "stosq"
+ "qword ptr es:[rdi], rax"
+ , Line 0x1006 [ 0x48, 0x8b, 0x05, 0x4d, 0xb5, 0x06, 0x00 ] []
+ "mov" "rax, qword ptr [rip + 0x6b54d]"
+ , Line 0x1b824 [ 0x9112a000 ] [] "add" "x0, x0, #0x4a8" ]
+
+ , testCase "the watch list names what lies outside" $
+ watchSection IntelDoitm "/lib.so"
+ [ x86 [ 0x48, 0xf7, 0xf6 ] "div" "rsi"
+ , x86 [ 0x48, 0x01, 0xd8 ] "add" "rax, rbx"
+ , x86 [ 0x92 ] "xchg" "eax, edx" ]
+ @?= T.unlines
+ [ "O /lib.so", "D 0 div rsi"
+ , "U 0 0 2 rax:0:32 rdx:0:32 xchg eax, edx" ]
+ ]
+ where
+ word w = Line 0 [ w ] [] "" ""
+ x86 bs m ops = Line 0 bs [] m ops
+
diffTests :: TestTree
diffTests = testGroup "diff"
[ testCase "a dump reads whole" $ do
@@ -299,6 +389,36 @@ diffTests = testGroup "diff"
-- a control dividing other operands sets it apart as unsteady
fmap inPc (dvUnsteady (diffControlled [ x ] [ a, b ])) @?= [ 0x40 ]
+ , testCase "an instruction outside the contract is reported apart" $ do
+ -- 0x40 runs once in every run, outside the contract, on other
+ -- operands in B; 0x30 is watched too, on the same operands
+ let under d = d <> "U 30 7777\nW 30 popcnt rax, rbx\nU 40 "
+ a <- either assertFailure pure
+ (readDump (under dumpA <> "1111\nM x86_64\nG intel-doitm\n"))
+ b <- either assertFailure pure
+ (readDump (under dumpB <> "2222\nM x86_64\nG intel-doitm\n"))
+ x <- either assertFailure pure
+ (readDump (under dumpA <> "3333\nM x86_64\nG intel-doitm\n"))
+ dpIsa a @?= Just "x86_64"
+ dpContract a @?= Just "intel-doitm"
+ M.lookup 0x30 (dpTexts a) @?= Just "popcnt rax, rbx"
+ let dv = diffDumps [ a, b ]
+ -- not an origin: the contract says nothing either way of it
+ fmap (\(o, i) -> (o, inPc i)) (dvOrigins dv)
+ @?= [ (ControlOrigin, 0x10), (AddressOrigin, 0x20) ]
+ fmap inPc (dvOutside dv) @?= [ 0x40 ]
+ M.lookup 0x40 (dvOutsideBehaviour (diffDumps [ a, b, a ]))
+ @?= Just ([ [ 0, 2 ], [ 1 ] ], [])
+ dvWatched dv @?= M.fromList [ ("/lib.so", S.fromList [ 0x30, 0x40 ]) ]
+ notElem 0x40 (fmap inPc (dvDownstream dv)) @? "downstream"
+ -- runs alike in their operands show nothing outside
+ dvOutside (diffDumps [ a, a ]) @?= []
+ -- a control on other operands sets it apart as unsteady
+ dvOutside (diffControlled [ x ] [ a, b ]) @?= []
+ fmap inPc (dvUnsteady (diffControlled [ x ] [ a, b ])) @?= [ 0x40 ]
+ -- and the objects kept are the objects reported
+ dvOutside (restrictTo [ "/other.so" ] dv) @?= []
+
, testCase "an origin is given the calls that reached it" $ do
-- 0x10 ran in context 2 (the call at 0x40 made in context 1,
-- the call at 0x30 made in the program's own) in A, and in the
