{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module: Vestigia.Diff
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Where runs that differ only in a secret differ. Each run is a
-- leakage trace summarised per instruction (the QEMU plugin's
-- dump): how often each instruction ran, how often it transferred
-- to each target, a fingerprint of the addresses it touched, and,
-- for an integer division, a fingerprint of its operands.
--
-- A branch whose outcome did not depend on the secret takes each
-- of its transfers in the same proportion however often it runs; a
-- branch whose outcomes differ in proportion between runs had its
-- own condition depend on the secret, and is a `control` origin
-- (a loop whose trip count the secret sets is one, though it also
-- runs a different number of times). So is a branch run as often,
-- taking each transfer as often, in another order: the plugin keeps
-- an order-sensitive fingerprint of what followed each instruction.
-- An instruction run equally often in every run whose addresses
-- differ computed one from the secret: an `address` origin. A
-- division, whose time depends on its operands, run equally often
-- on other operands is an `operand` origin. Every
-- other instruction run a different number of times sits where
-- control had already diverged: it is downstream. So is a return
-- whose transfers differ, however often it ran: it goes where the
-- call before it sent it, so its outcomes differ only because
-- control had diverged before the call.
--
-- Unlike memcheck's taint, this sees what control flow does to
-- data as well as what data does: a value chosen by a secret
-- branch and then used as an index differs between runs, though
-- no undefined bit ever reached it. It sees only what the chosen
-- secrets actually varied.
--
-- A difference means the secret only if nothing else differs
-- between runs. Controls are runs repeating the first run's secret:
-- an instruction that differs between the first run and a control
-- differs without the secret (an entropy source, a clock) and is
-- `unsteady`, counted and excluded from the origins.
--
-- Runs designed to reach a particular path are compared beside these
-- but not alike: they differ from the others in where they go, not
-- only in the secret, so an instruction's addresses differing in one
-- of them says nothing about the secret. A designed run counts toward
-- the control origins (a branch whose outcomes shift under it chose
-- by the secret) and what was executed, never toward the address or
-- operand origins, which only runs alike in all but the secret can
-- show.
--
-- What every run executed, per object, is reported beside: the
-- instructions the chosen secrets exercised, and so, against what
-- a function could execute, the part of it the comparison saw.
--
-- Each origin names how the runs behaved there: the runs alike at
-- it, grouped (taking each transfer in the same proportion, at a
-- control origin; touching the same addresses, at an address
-- origin; dividing the same operands, at an operand origin), and the
-- 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(..)
  , Run(..)
  , Dump(..)
  , readDump
  , callsOf
  , runApart
  , Kind(..)
  , Named(..)
  , Origin(..)
  , Divergence(..)
  , diffDumps
  , diffControlled
  , diffDesigned
  , restrictTo
  , loadBases
  , layoutApart
  , divergenceJson
  , divergenceSummary
  ) where

import Control.Monad (foldM, unless)
import qualified Data.ByteString as BS
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
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(..))

-- | One instruction of a run: its run-time address, and its object
--   and address there, where the object's program headers place it.
data Insn = Insn {
    Insn -> Integer
inPc :: !Integer
  , Insn -> Integer
inCount :: !Integer
  , Insn -> Integer
inAccesses :: !Integer
  , Insn -> Text
inFingerprint :: !T.Text
    -- | what followed it, in order, fingerprinted
  , Insn -> Text
inOrder :: !T.Text
  , Insn -> Maybe Text
inObject :: !(Maybe T.Text)
  , Insn -> Integer
inOffset :: !Integer
  } deriving (Insn -> Insn -> Bool
(Insn -> Insn -> Bool) -> (Insn -> Insn -> Bool) -> Eq Insn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Insn -> Insn -> Bool
== :: Insn -> Insn -> Bool
$c/= :: Insn -> Insn -> Bool
/= :: Insn -> Insn -> Bool
Eq, Int -> Insn -> ShowS
[Insn] -> ShowS
Insn -> String
(Int -> Insn -> ShowS)
-> (Insn -> String) -> ([Insn] -> ShowS) -> Show Insn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Insn -> ShowS
showsPrec :: Int -> Insn -> ShowS
$cshow :: Insn -> String
show :: Insn -> String
$cshowList :: [Insn] -> ShowS
showList :: [Insn] -> ShowS
Show)

-- | How a run was made, as `vestigia record` appends it to the
--   plugin's dump: the program and its arguments, as the bytes it
--   passed them; the variables of the environment the guest was
--   given, and the bytes they take; and the run's exit status.
data Run = Run {
    Run -> [ByteString]
rnArguments :: ![BS.ByteString]
  , Run -> (Integer, Integer)
rnEnvironment :: !(Integer, Integer)
  , Run -> Integer
rnStatus :: !Integer
  } deriving (Run -> Run -> Bool
(Run -> Run -> Bool) -> (Run -> Run -> Bool) -> Eq Run
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Run -> Run -> Bool
== :: Run -> Run -> Bool
$c/= :: Run -> Run -> Bool
/= :: Run -> Run -> Bool
Eq, Int -> Run -> ShowS
[Run] -> ShowS
Run -> String
(Int -> Run -> ShowS)
-> (Run -> String) -> ([Run] -> ShowS) -> Show Run
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Run -> ShowS
showsPrec :: Int -> Run -> ShowS
$cshow :: Run -> String
show :: Run -> String
$cshowList :: [Run] -> ShowS
showList :: [Run] -> ShowS
Show)

-- | One run: its instructions by address, its transfers by source,
--   each a count per target, the instructions that return, the
--   divisions' operands, fingerprinted, the contexts calls made (each
--   by the context it was made in and the call's address, 0 being
--   the program's own), the contexts each instruction ran in (with
--   whether it ran in more than the plugin kept), and how the run
--   was made, where its dump says.
data Dump = Dump {
    Dump -> Map Integer Insn
dpInsns :: !(M.Map Integer Insn)
  , Dump -> Map Integer (Map Integer Integer)
dpTransfers :: !(M.Map Integer (M.Map Integer Integer))
  , Dump -> Set Integer
dpReturns :: !(S.Set Integer)
  , Dump -> Map Integer Text
dpOperands :: !(M.Map Integer T.Text)
  , Dump -> Map Integer (Integer, Integer)
dpContexts :: !(M.Map Integer (Integer, Integer))
  , Dump -> Map Integer (Bool, [Integer])
dpCallers :: !(M.Map Integer (Bool, [Integer]))
  , Dump -> Maybe Run
dpRun :: !(Maybe Run)
    -- | the operands, fingerprinted, of the instructions outside the
    --   contract the run was recorded under
  , Dump -> Map Integer Text
dpOutside :: !(M.Map Integer T.Text)
    -- | the text of each instruction the watch list named
  , Dump -> Map Integer Text
dpTexts :: !(M.Map Integer T.Text)
    -- | the guest's ISA, the contract, and the CPU model QEMU
    --   emulated, as `vestigia record` appends them
  , Dump -> Maybe Text
dpIsa :: !(Maybe T.Text)
  , Dump -> Maybe Text
dpContract :: !(Maybe T.Text)
  , Dump -> Maybe Text
dpCpu :: !(Maybe T.Text)
  } deriving (Dump -> Dump -> Bool
(Dump -> Dump -> Bool) -> (Dump -> Dump -> Bool) -> Eq Dump
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dump -> Dump -> Bool
== :: Dump -> Dump -> Bool
$c/= :: Dump -> Dump -> Bool
/= :: Dump -> Dump -> Bool
Eq, Int -> Dump -> ShowS
[Dump] -> ShowS
Dump -> String
(Int -> Dump -> ShowS)
-> (Dump -> String) -> ([Dump] -> ShowS) -> Show Dump
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dump -> ShowS
showsPrec :: Int -> Dump -> ShowS
$cshow :: Dump -> String
show :: Dump -> String
$cshowList :: [Dump] -> ShowS
showList :: [Dump] -> ShowS
Show)

-- | Read a plugin dump. A dump in which no instruction ran records
--   no run (the plugin writes every instruction the guest executed),
--   and is refused rather than compared as one that did nothing, as
--   is the dump of a guest the plugin stopped for starting a second
--   thread, or one whose contexts do not chain back to the
--   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. Beside it, @M@ names the guest's ISA, @G@
--   the contract the run was recorded under, and @P@ the CPU model
--   QEMU emulated, where one was named.
readDump :: T.Text -> Either String Dump
readDump :: Text -> Either String Dump
readDump Text
t = do
  d <- ((Dump, [ByteString], Maybe (Integer, Integer), Maybe Integer)
 -> Text
 -> Either
      String
      (Dump, [ByteString], Maybe (Integer, Integer), Maybe Integer))
-> (Dump, [ByteString], Maybe (Integer, Integer), Maybe Integer)
-> [Text]
-> Either
     String
     (Dump, [ByteString], Maybe (Integer, Integer), Maybe Integer)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Dump, [ByteString], Maybe (Integer, Integer), Maybe Integer)
-> Text
-> Either
     String
     (Dump, [ByteString], Maybe (Integer, Integer), Maybe Integer)
forall {a} {a} {a}.
(Eq a, Eq a, Num a, Num a, Read a) =>
(Dump, [ByteString], Maybe (a, a), Maybe a)
-> Text
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
line (Map Integer Insn
-> Map Integer (Map Integer Integer)
-> Set Integer
-> Map Integer Text
-> Map Integer (Integer, Integer)
-> Map Integer (Bool, [Integer])
-> Maybe Run
-> Map Integer Text
-> Map Integer Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Dump
Dump Map Integer Insn
forall k a. Map k a
M.empty Map Integer (Map Integer Integer)
forall k a. Map k a
M.empty Set Integer
forall a. Set a
S.empty Map Integer Text
forall k a. Map k a
M.empty Map Integer (Integer, Integer)
forall k a. Map k a
M.empty Map Integer (Bool, [Integer])
forall k a. Map k a
M.empty
                     Maybe Run
forall a. Maybe a
Nothing Map Integer Text
forall k a. Map k a
M.empty Map Integer Text
forall k a. Map k a
M.empty Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing, []
                  , Maybe (Integer, Integer)
forall a. Maybe a
Nothing
                  , Maybe Integer
forall a. Maybe a
Nothing) (Text -> [Text]
T.lines Text
t)
  let (dump, as, env, st) = d
      cx = Dump -> Map Integer (Integer, Integer)
dpContexts Dump
dump
  unless (any ((> 0) . inCount) (M.elems (dpInsns dump))) $
    Left "no instruction ran: the run was not recorded"
  -- each context made in one made before it, so that its calls end
  unless (and [ c' < c && (c' == 0 || M.member c' cx)
              | (c, (c', _)) <- M.toList cx ]) $
    Left "a context made in one not made before it"
  unless (and [ c == 0 || M.member c cx
              | (_, cs) <- M.elems (dpCallers dump), c <- cs ]) $
    Left "an instruction run in a context the dump does not make"
  r <- record (reverse as) env st
  pure dump { dpRun = r }
  where
    line :: (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Text
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
line (Dump
d, [ByteString]
as, Maybe (a, a)
env, Maybe a
st) Text
l = case Text -> [Text]
T.words Text
l of
      [ Text
"I", Text
pc, Text
n, Text
a, Text
fp, Text
ord, Text
obj, Text
off ] -> do
        i <- Integer
-> Integer
-> Integer
-> Text
-> Text
-> Maybe Text
-> Integer
-> Insn
Insn (Integer
 -> Integer
 -> Integer
 -> Text
 -> Text
 -> Maybe Text
 -> Integer
 -> Insn)
-> Either String Integer
-> Either
     String
     (Integer
      -> Integer -> Text -> Text -> Maybe Text -> Integer -> Insn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
pc Either
  String
  (Integer
   -> Integer -> Text -> Text -> Maybe Text -> Integer -> Insn)
-> Either String Integer
-> Either
     String (Integer -> Text -> Text -> Maybe Text -> Integer -> Insn)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
n Either
  String (Integer -> Text -> Text -> Maybe Text -> Integer -> Insn)
-> Either String Integer
-> Either String (Text -> Text -> Maybe Text -> Integer -> Insn)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
a Either String (Text -> Text -> Maybe Text -> Integer -> Insn)
-> Either String Text
-> Either String (Text -> Maybe Text -> Integer -> Insn)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
fp
                  Either String (Text -> Maybe Text -> Integer -> Insn)
-> Either String Text
-> Either String (Maybe Text -> Integer -> Insn)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
ord
                  Either String (Maybe Text -> Integer -> Insn)
-> Either String (Maybe Text) -> Either String (Integer -> Insn)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> Either String (Maybe Text)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Text
obj Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-" then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
obj)
                  Either String (Integer -> Insn)
-> Either String Integer -> Either String Insn
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
off
        pure (d { dpInsns = M.insert (inPc i) i (dpInsns d) }, as, env
             , st)
      [ Text
"E", Text
from, Text
to, Text
n ] -> do
        f <- Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
from
        k <- unhex to
        c <- unhex n
        pure (d { dpTransfers = M.insertWith M.union f (M.singleton k c)
                    (dpTransfers d) }, as, env, st)
      [ Text
"R", Text
pc ] -> do
        r <- Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
pc
        pure (d { dpReturns = S.insert r (dpReturns d) }, as, env, st)
      [ Text
"D", Text
pc, Text
fp ] -> do
        k <- Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
pc
        pure (d { dpOperands = M.insert k fp (dpOperands d) }, as, env
             , st)
      [ Text
"U", Text
pc, Text
fp ] -> do
        k <- Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
pc
        pure (d { dpOutside = M.insert k fp (dpOutside d) }, as, env
             , st)
      (Text
"W" : Text
pc : text :: [Text]
text@(Text
_ : [Text]
_)) -> do
        k <- Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
pc
        pure (d { dpTexts = M.insert k (T.unwords text) (dpTexts d) }, as
             , env, st)
      [ Text
"M", Text
isa ] -> (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dump
d { dpIsa = Just isa }, [ByteString]
as, Maybe (a, a)
env, Maybe a
st)
      [ Text
"G", Text
c ] -> (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dump
d { dpContract = Just c }, [ByteString]
as, Maybe (a, a)
env, Maybe a
st)
      [ Text
"P", Text
c ] -> (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dump
d { dpCpu = Just c }, [ByteString]
as, Maybe (a, a)
env, Maybe a
st)
      [ Text
"C", Text
c, Text
caller, Text
call ] -> do
        v <- (,) (Integer -> Integer -> (Integer, Integer))
-> Either String Integer
-> Either String (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
caller Either String (Integer -> (Integer, Integer))
-> Either String Integer -> Either String (Integer, Integer)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
call
        k <- unhex c
        pure (d { dpContexts = M.insert k v (dpContexts d) }, as, env
             , st)
      (Text
"K" : Text
pc : Text
partial : cs :: [Text]
cs@(Text
_ : [Text]
_)) -> do
        k <- Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
pc
        p <- case partial of
          Text
"0" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Text
"1" -> Bool -> Either String Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          Text
_ -> String -> Either String Bool
forall a b. a -> Either a b
Left (String
"an unreadable dump line: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
l)
        xs <- traverse unhex cs
        pure (d { dpCallers = M.insert k (p, xs) (dpCallers d) }, as
             , env, st)
      [ Text
"T", Text
_ ] ->
        String -> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a b. a -> Either a b
Left String
"the guest started a second thread, which a trace \
             \cannot record: the run was stopped"
      [ Text
"A" ] -> (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dump
d, ByteString
BS.empty ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
as, Maybe (a, a)
env, Maybe a
st)
      [ Text
"A", Text
h ] -> do
        b <- Text -> Either String ByteString
unhexBytes Text
h
        pure (d, b : as, env, st)
      [ Text
"N", Text
n, Text
b ] -> do
        v <- (,) (a -> a -> (a, a))
-> Either String a -> Either String (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String a
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
n Either String (a -> (a, a))
-> Either String a -> Either String (a, a)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String a
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex Text
b
        pure (d, as, Just v, st)
      [ Text
"X", Text
x ] -> case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
x) of
        Just a
v -> (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dump
d, [ByteString]
as, Maybe (a, a)
env, a -> Maybe a
forall a. a -> Maybe a
Just a
v)
        Maybe a
Nothing -> String -> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a b. a -> Either a b
Left (String
"not an exit status: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
x)
      [] -> (Dump, [ByteString], Maybe (a, a), Maybe a)
-> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dump
d, [ByteString]
as, Maybe (a, a)
env, Maybe a
st)
      [Text]
_ -> String -> Either String (Dump, [ByteString], Maybe (a, a), Maybe a)
forall a b. a -> Either a b
Left (String
"an unreadable dump line: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
l)
    record :: [ByteString]
-> Maybe (Integer, Integer)
-> Maybe Integer
-> Either a (Maybe Run)
record [ByteString]
as Maybe (Integer, Integer)
env Maybe Integer
st = case ([ByteString]
as, Maybe (Integer, Integer)
env, Maybe Integer
st) of
      ([], Maybe (Integer, Integer)
Nothing, Maybe Integer
Nothing) -> Maybe Run -> Either a (Maybe Run)
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Run
forall a. Maybe a
Nothing
      (ByteString
_ : [ByteString]
_, Just (Integer, Integer)
e, Just Integer
x) -> Maybe Run -> Either a (Maybe Run)
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Run -> Maybe Run
forall a. a -> Maybe a
Just ([ByteString] -> (Integer, Integer) -> Integer -> Run
Run [ByteString]
as (Integer, Integer)
e Integer
x))
      ([ByteString], Maybe (Integer, Integer), Maybe Integer)
_ -> a -> Either a (Maybe Run)
forall a b. a -> Either a b
Left a
"an incomplete record of the run"
    unhex :: Text -> Either String a
unhex Text
x = case ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
x) of
      [ (a
v, String
"") ] -> a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
      [(a, String)]
_ -> String -> Either String a
forall a b. a -> Either a b
Left (String
"not hexadecimal: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
x)
    unhexBytes :: Text -> Either String ByteString
unhexBytes Text
h
      | Int -> Bool
forall a. Integral a => a -> Bool
odd (Text -> Int
T.length Text
h) = String -> Either String ByteString
forall a b. a -> Either a b
Left (String
"not hexadecimal bytes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
h)
      | Bool
otherwise =
          [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> Either String [Word8] -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either String Word8) -> [Text] -> Either String [Word8]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Integer -> Word8) -> Either String Integer -> Either String Word8
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Either String Integer -> Either String Word8)
-> (Text -> Either String Integer) -> Text -> Either String Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Integer
forall {a}. (Eq a, Num a) => Text -> Either String a
unhex) (Int -> Text -> [Text]
T.chunksOf Int
2 Text
h)

-- | The calls that made a context, innermost first, at most 24 of
--   them (as memcheck keeps): each by its object and address there,
--   or by its run-time address where the run names no object for it.
callsOf :: Dump -> Integer -> [(Maybe T.Text, Integer)]
callsOf :: Dump -> Integer -> [(Maybe Text, Integer)]
callsOf Dump
d = Int -> Integer -> [(Maybe Text, Integer)]
forall {t}.
(Ord t, Num t) =>
t -> Integer -> [(Maybe Text, Integer)]
go (Int
24 :: Int)
  where
    go :: t -> Integer -> [(Maybe Text, Integer)]
go t
n Integer
c
      | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 Bool -> Bool -> Bool
|| Integer
c Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = []
      | Bool
otherwise = case Integer
-> Map Integer (Integer, Integer) -> Maybe (Integer, Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
c (Dump -> Map Integer (Integer, Integer)
dpContexts Dump
d) of
          Just (Integer
caller, Integer
pc) -> Integer -> (Maybe Text, Integer)
site Integer
pc (Maybe Text, Integer)
-> [(Maybe Text, Integer)] -> [(Maybe Text, Integer)]
forall a. a -> [a] -> [a]
: t -> Integer -> [(Maybe Text, Integer)]
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Integer
caller
          Maybe (Integer, Integer)
Nothing -> []
    site :: Integer -> (Maybe Text, Integer)
site Integer
pc = case Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d) of
      Just Insn
i | Just Text
o <- Insn -> Maybe Text
inObject Insn
i -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
o, Insn -> Integer
inOffset Insn
i)
      Maybe Insn
_ -> (Maybe Text
forall a. Maybe a
Nothing, Integer
pc)

-- | Why a run cannot be set beside the first as differing from it in
--   the secret alone, if it cannot: it ran another program, its
--   arguments differ from the first run's in number or length, or it
--   was given an environment of another size. Each lays the guest's
--   stack out apart, and so every address on it.
runApart :: Run -> Run -> Maybe String
runApart :: Run -> Run -> Maybe String
runApart Run
first Run
r
  | Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take Int
1 (Run -> [ByteString]
rnArguments Run
r) [ByteString] -> [ByteString] -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
take Int
1 (Run -> [ByteString]
rnArguments Run
first) =
      String -> Maybe String
forall a. a -> Maybe a
Just String
"ran another program than the first run"
  | (ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Int
BS.length (Run -> [ByteString]
rnArguments Run
r)
      [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= (ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Int
BS.length (Run -> [ByteString]
rnArguments Run
first) =
      String -> Maybe String
forall a. a -> Maybe a
Just String
"has arguments that differ from the first run's in number \
           \or length"
  | Run -> (Integer, Integer)
rnEnvironment Run
r (Integer, Integer) -> (Integer, Integer) -> Bool
forall a. Eq a => a -> a -> Bool
/= Run -> (Integer, Integer)
rnEnvironment Run
first =
      String -> Maybe String
forall a. a -> Maybe a
Just String
"was given an environment of another size than the first \
           \run's"
  | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

-- | What a run is to a comparison: declared, designed for a path, or
--   a control repeating the first run's secret.
data Kind =
    DeclaredRun
  | DesignedRun
  | ControlRun
  deriving (Kind -> Kind -> Bool
(Kind -> Kind -> Bool) -> (Kind -> Kind -> Bool) -> Eq Kind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Kind -> Kind -> Bool
== :: Kind -> Kind -> Bool
$c/= :: Kind -> Kind -> Bool
/= :: Kind -> Kind -> Bool
Eq, Int -> Kind -> ShowS
[Kind] -> ShowS
Kind -> String
(Int -> Kind -> ShowS)
-> (Kind -> String) -> ([Kind] -> ShowS) -> Show Kind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Kind -> ShowS
showsPrec :: Int -> Kind -> ShowS
$cshow :: Kind -> String
show :: Kind -> String
$cshowList :: [Kind] -> ShowS
showList :: [Kind] -> ShowS
Show)

-- | A run as the report names it: by its dump's file name, with what
--   it is to the comparison and how it was made.
data Named = Named {
    Named -> Text
nmName :: !T.Text
  , Named -> Kind
nmKind :: !Kind
  , Named -> Run
nmRun :: !Run
  } deriving (Named -> Named -> Bool
(Named -> Named -> Bool) -> (Named -> Named -> Bool) -> Eq Named
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Named -> Named -> Bool
== :: Named -> Named -> Bool
$c/= :: Named -> Named -> Bool
/= :: Named -> Named -> Bool
Eq, Int -> Named -> ShowS
[Named] -> ShowS
Named -> String
(Int -> Named -> ShowS)
-> (Named -> String) -> ([Named] -> ShowS) -> Show Named
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Named -> ShowS
showsPrec :: Int -> Named -> ShowS
$cshow :: Named -> String
show :: Named -> String
$cshowList :: [Named] -> ShowS
showList :: [Named] -> ShowS
Show)

-- | Where a run loaded each object it executed: any of its
--   instructions' run-time addresses less its address in the object.
loadBases :: Dump -> M.Map T.Text Integer
loadBases :: Dump -> Map Text Integer
loadBases Dump
d = [(Text, Integer)] -> Map Text Integer
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
o, Insn -> Integer
inPc Insn
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Insn -> Integer
inOffset Insn
i)
  | Insn
i <- Map Integer Insn -> [Insn]
forall k a. Map k a -> [a]
M.elems (Dump -> Map Integer Insn
dpInsns Dump
d), Just Text
o <- [ Insn -> Maybe Text
inObject Insn
i ] ]

-- | The objects two runs both executed but loaded at different
--   addresses, each with where the first run put it and where the
--   second did. Runs laid out apart touch other addresses wherever
--   they touch memory, so comparing them says nothing of the
--   secret.
layoutApart :: Dump -> Dump -> [(T.Text, Integer, Integer)]
layoutApart :: Dump -> Dump -> [(Text, Integer, Integer)]
layoutApart Dump
a Dump
b =
  [ (Text
o, Integer
x, Integer
y)
  | (Text
o, (Integer
x, Integer
y)) <- Map Text (Integer, Integer) -> [(Text, (Integer, Integer))]
forall k a. Map k a -> [(k, a)]
M.toList
      ((Integer -> Integer -> (Integer, Integer))
-> Map Text Integer
-> Map Text Integer
-> Map Text (Integer, Integer)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) (Dump -> Map Text Integer
loadBases Dump
a) (Dump -> Map Text Integer
loadBases Dump
b))
  , Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
y ]

-- | How an origin depended on the secret.
data Origin =
    ControlOrigin
  | AddressOrigin
  | OperandOrigin
  deriving (Origin -> Origin -> Bool
(Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool) -> Eq Origin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Origin -> Origin -> Bool
== :: Origin -> Origin -> Bool
$c/= :: Origin -> Origin -> Bool
/= :: Origin -> Origin -> Bool
Eq, Eq Origin
Eq Origin =>
(Origin -> Origin -> Ordering)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Origin)
-> (Origin -> Origin -> Origin)
-> Ord Origin
Origin -> Origin -> Bool
Origin -> Origin -> Ordering
Origin -> Origin -> Origin
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Origin -> Origin -> Ordering
compare :: Origin -> Origin -> Ordering
$c< :: Origin -> Origin -> Bool
< :: Origin -> Origin -> Bool
$c<= :: Origin -> Origin -> Bool
<= :: Origin -> Origin -> Bool
$c> :: Origin -> Origin -> Bool
> :: Origin -> Origin -> Bool
$c>= :: Origin -> Origin -> Bool
>= :: Origin -> Origin -> Bool
$cmax :: Origin -> Origin -> Origin
max :: Origin -> Origin -> Origin
$cmin :: Origin -> Origin -> Origin
min :: Origin -> Origin -> Origin
Ord, Int -> Origin -> ShowS
[Origin] -> ShowS
Origin -> String
(Int -> Origin -> ShowS)
-> (Origin -> String) -> ([Origin] -> ShowS) -> Show Origin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Origin -> ShowS
showsPrec :: Int -> Origin -> ShowS
$cshow :: Origin -> String
show :: Origin -> String
$cshowList :: [Origin] -> ShowS
showList :: [Origin] -> ShowS
Show)

-- | Where the runs differ: the origins, each an instruction run
--   equally often everywhere, and how many instructions ran a
--   different number of times.
data Divergence = Divergence {
    Divergence -> [(Origin, Insn)]
dvOrigins :: ![(Origin, Insn)]
    -- | at each origin, the runs alike there, grouped, and the runs
    --   that never reached it, as indices into the declared runs
    --   then the designed (an address or operand origin's, the
    --   declared alone)
  , Divergence -> Map (Origin, Integer) ([[Int]], [Int])
dvBehaviour :: !(M.Map (Origin, Integer) ([[Int]], [Int]))
  , Divergence -> [Insn]
dvDownstream :: ![Insn]
  , Divergence -> [Insn]
dvUnsteady :: ![Insn]
  , Divergence -> Int
dvRuns :: !Int
  , Divergence -> Int
dvControls :: !Int
  , Divergence -> Int
dvDesigned :: !Int
    -- | the offsets some run, control or not, executed, by object
  , Divergence -> Map Text (Set Integer)
dvExecuted :: !(M.Map T.Text (S.Set Integer))
    -- | at each origin, the distinct chains of calls that reached it
    --   in the declared and designed runs, at most 16 of them, and
    --   whether there were more than those
  , Divergence -> Map Integer ([[(Maybe Text, Integer)]], Bool)
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
  , Divergence -> [Insn]
dvOutside :: ![Insn]
  , Divergence -> Map Integer ([[Int]], [Int])
dvOutsideBehaviour :: !(M.Map Integer ([[Int]], [Int]))
    -- | the instructions outside the contract some run executed, by
    --   object
  , Divergence -> Map Text (Set Integer)
dvWatched :: !(M.Map T.Text (S.Set Integer))
    -- | the text of each instruction the watch list named
  , Divergence -> Map Integer Text
dvTexts :: !(M.Map Integer T.Text)
    -- | the guest's ISA, the contract, and the CPU model, as the
    --   declared runs name them
  , Divergence -> Maybe Text
dvIsa :: !(Maybe T.Text)
  , Divergence -> Maybe Text
dvContract :: !(Maybe T.Text)
  , Divergence -> Maybe Text
dvCpu :: !(Maybe T.Text)
  } deriving (Divergence -> Divergence -> Bool
(Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Bool) -> Eq Divergence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Divergence -> Divergence -> Bool
== :: Divergence -> Divergence -> Bool
$c/= :: Divergence -> Divergence -> Bool
/= :: Divergence -> Divergence -> Bool
Eq, Int -> Divergence -> ShowS
[Divergence] -> ShowS
Divergence -> String
(Int -> Divergence -> ShowS)
-> (Divergence -> String)
-> ([Divergence] -> ShowS)
-> Show Divergence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Divergence -> ShowS
showsPrec :: Int -> Divergence -> ShowS
$cshow :: Divergence -> String
show :: Divergence -> String
$cshowList :: [Divergence] -> ShowS
showList :: [Divergence] -> ShowS
Show)

-- | Compare runs, uncontrolled.
diffDumps :: [Dump] -> Divergence
diffDumps :: [Dump] -> Divergence
diffDumps = [Dump] -> [Dump] -> Divergence
diffControlled []

-- | Compare runs, given controls repeating the first run's secret.
--   Every run is set against every other, so an origin is any
--   instruction at which some two runs differ, and which no control
--   shows differing without the secret.
diffControlled :: [Dump] -> [Dump] -> Divergence
diffControlled :: [Dump] -> [Dump] -> Divergence
diffControlled [Dump]
cs [Dump]
ds = [Dump] -> [Dump] -> [Dump] -> Divergence
diffDesigned [Dump]
cs [Dump]
ds []

-- | Compare runs, given controls and runs designed to reach particular
--   paths. The address and operand origins are the declared runs'
--   alone; the control origins and what was executed are every
--   run's.
diffDesigned :: [Dump] -> [Dump] -> [Dump] -> Divergence
diffDesigned :: [Dump] -> [Dump] -> [Dump] -> Divergence
diffDesigned [Dump]
cs [Dump]
ds [Dump]
xs = Divergence {
    dvOrigins :: [(Origin, Insn)]
dvOrigins = ((Origin, Insn) -> Integer) -> [(Origin, Insn)] -> [(Origin, Insn)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Insn -> Integer
inPc (Insn -> Integer)
-> ((Origin, Insn) -> Insn) -> (Origin, Insn) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Origin, Insn) -> Insn
forall a b. (a, b) -> b
snd) [(Origin, Insn)]
origins
  , dvBehaviour :: Map (Origin, Integer) ([[Int]], [Int])
dvBehaviour = [((Origin, Integer), ([[Int]], [Int]))]
-> Map (Origin, Integer) ([[Int]], [Int])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ ((Origin
o, Insn -> Integer
inPc Insn
i), Origin -> Integer -> ([[Int]], [Int])
forall {a}. (Num a, Enum a) => Origin -> Integer -> ([[Int]], [a])
behaviourAt Origin
o (Insn -> Integer
inPc Insn
i)) | (Origin
o, Insn
i) <- [(Origin, Insn)]
origins ]
  , dvDownstream :: [Insn]
dvDownstream = [ Insn
i | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
downstream
                       , Bool -> Bool
not (Integer
pc Integer -> Set Integer -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Integer
unsteady)
                       , Just Insn
i <- [ Integer -> Maybe Insn
firstInsn Integer
pc ] ]
  , dvUnsteady :: [Insn]
dvUnsteady = [ Insn
i | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
unsteady
                     , Just Insn
i <- [ Integer -> Maybe Insn
firstInsn Integer
pc ] ]
  , dvRuns :: Int
dvRuns = [Dump] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Dump]
ds
  , dvControls :: Int
dvControls = [Dump] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Dump]
cs
  , dvDesigned :: Int
dvDesigned = [Dump] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Dump]
xs
  , dvExecuted :: Map Text (Set Integer)
dvExecuted = (Set Integer -> Set Integer -> Set Integer)
-> [(Text, Set Integer)] -> Map Text (Set Integer)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
S.union
      [ (Text
obj, Integer -> Set Integer
forall a. a -> Set a
S.singleton (Insn -> Integer
inOffset Insn
i))
      | Dump
d <- [Dump]
ds [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
xs [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
cs
      , Insn
i <- Map Integer Insn -> [Insn]
forall k a. Map k a -> [a]
M.elems (Dump -> Map Integer Insn
dpInsns Dump
d)
      , Insn -> Integer
inCount Insn
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
      , Just Text
obj <- [ Insn -> Maybe Text
inObject Insn
i ] ]
  , dvCallers :: Map Integer ([[(Maybe Text, Integer)]], Bool)
dvCallers = [(Integer, ([[(Maybe Text, Integer)]], Bool))]
-> Map Integer ([[(Maybe Text, Integer)]], Bool)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ (Insn -> Integer
inPc Insn
i, Integer -> ([[(Maybe Text, Integer)]], Bool)
callersAt (Insn -> Integer
inPc Insn
i))
      | Insn
i <- ((Origin, Insn) -> Insn) -> [(Origin, Insn)] -> [Insn]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Origin, Insn) -> Insn
forall a b. (a, b) -> b
snd [(Origin, Insn)]
origins [Insn] -> [Insn] -> [Insn]
forall a. Semigroup a => a -> a -> a
<> [Insn]
outside ]
  , dvOutside :: [Insn]
dvOutside = [Insn]
outside
  , dvOutsideBehaviour :: Map Integer ([[Int]], [Int])
dvOutsideBehaviour = [(Integer, ([[Int]], [Int]))] -> Map Integer ([[Int]], [Int])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ ( Insn -> Integer
inPc Insn
i
        , ( (Maybe Text -> Maybe Text -> Bool)
-> [(Int, Maybe Text)] -> [[Int]]
forall a. (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) [ (Int
k, Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Insn -> Integer
inPc Insn
i) (Dump -> Map Integer Text
dpOutside Dump
d))
                         | (Int
k, Dump
d) <- [Dump] -> Integer -> [(Int, Dump)]
forall {a}. (Num a, Enum a) => [Dump] -> Integer -> [(a, Dump)]
ranIn' [Dump]
ds (Insn -> Integer
inPc Insn
i) ]
          , [ Int
k | (Int
k, Dump
d) <- [Int] -> [Dump] -> [(Int, Dump)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ Int
0 .. ] [Dump]
ds
                , Bool -> (Insn -> Bool) -> Maybe Insn -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (Integer -> Bool) -> (Insn -> Integer) -> Insn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Insn -> Integer
inCount)
                    (Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Insn -> Integer
inPc Insn
i) (Dump -> Map Integer Insn
dpInsns Dump
d)) ] ) )
      | Insn
i <- [Insn]
outside ]
  , dvWatched :: Map Text (Set Integer)
dvWatched = (Set Integer -> Set Integer -> Set Integer)
-> [(Text, Set Integer)] -> Map Text (Set Integer)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
S.union
      [ (Text
obj, Integer -> Set Integer
forall a. a -> Set a
S.singleton (Insn -> Integer
inOffset Insn
i))
      | Dump
d <- [Dump]
ds [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
xs [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
cs
      , Integer
pc <- Map Integer Text -> [Integer]
forall k a. Map k a -> [k]
M.keys (Dump -> Map Integer Text
dpOutside Dump
d)
      , Just Insn
i <- [ Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d) ]
      , Insn -> Integer
inCount Insn
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
      , Just Text
obj <- [ Insn -> Maybe Text
inObject Insn
i ] ]
  , dvTexts :: Map Integer Text
dvTexts = [Map Integer Text] -> Map Integer Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ((Dump -> Map Integer Text) -> [Dump] -> [Map Integer Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dump -> Map Integer Text
dpTexts ([Dump]
ds [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
xs [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
cs))
  , dvIsa :: Maybe Text
dvIsa = case [Dump]
ds of
      (Dump
d : [Dump]
_) -> Dump -> Maybe Text
dpIsa Dump
d
      [] -> Maybe Text
forall a. Maybe a
Nothing
  , dvContract :: Maybe Text
dvContract = case [Dump]
ds of
      (Dump
d : [Dump]
_) -> Dump -> Maybe Text
dpContract Dump
d
      [] -> Maybe Text
forall a. Maybe a
Nothing
  , dvCpu :: Maybe Text
dvCpu = case [Dump]
ds of
      (Dump
d : [Dump]
_) -> Dump -> Maybe Text
dpCpu Dump
d
      [] -> Maybe Text
forall a. Maybe a
Nothing
  }
  where
    ranIn' :: [Dump] -> Integer -> [(a, Dump)]
ranIn' [Dump]
rs Integer
pc = [ (a
k, Dump
d) | (a
k, Dump
d) <- [a] -> [Dump] -> [(a, Dump)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ a
0 .. ] [Dump]
rs
                            , Just Insn
i <- [ Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d) ]
                            , Insn -> Integer
inCount Insn
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ]
    callersAt :: Integer -> ([[(Maybe Text, Integer)]], Bool)
callersAt Integer
pc =
      let found :: [(Bool, [[(Maybe Text, Integer)]])]
found = [ (Bool
partial, (Integer -> [(Maybe Text, Integer)])
-> [Integer] -> [[(Maybe Text, Integer)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dump -> Integer -> [(Maybe Text, Integer)]
callsOf Dump
d) [Integer]
ks)
                  | Dump
d <- [Dump]
runs
                  , Just (Bool
partial, [Integer]
ks) <- [ Integer -> Map Integer (Bool, [Integer]) -> Maybe (Bool, [Integer])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer (Bool, [Integer])
dpCallers Dump
d) ] ]
          stacks :: [[(Maybe Text, Integer)]]
stacks = [[(Maybe Text, Integer)]] -> [[(Maybe Text, Integer)]]
forall a. Eq a => [a] -> [a]
L.nub (((Bool, [[(Maybe Text, Integer)]]) -> [[(Maybe Text, Integer)]])
-> [(Bool, [[(Maybe Text, Integer)]])] -> [[(Maybe Text, Integer)]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool, [[(Maybe Text, Integer)]]) -> [[(Maybe Text, Integer)]]
forall a b. (a, b) -> b
snd [(Bool, [[(Maybe Text, Integer)]])]
found)
      in (Int -> [[(Maybe Text, Integer)]] -> [[(Maybe Text, Integer)]]
forall a. Int -> [a] -> [a]
take Int
16 [[(Maybe Text, Integer)]]
stacks, ((Bool, [[(Maybe Text, Integer)]]) -> Bool)
-> [(Bool, [[(Maybe Text, Integer)]])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool, [[(Maybe Text, Integer)]]) -> Bool
forall a b. (a, b) -> a
fst [(Bool, [[(Maybe Text, Integer)]])]
found Bool -> Bool -> Bool
|| [[(Maybe Text, Integer)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Maybe Text, Integer)]]
stacks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16)

    -- what differs between the first run and a repeat of its secret
    unsteady :: Set Integer
unsteady = case [Dump]
ds of
      (Dump
d : [Dump]
_) -> [Set Integer] -> Set Integer
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Dump -> Set Integer) -> [Dump] -> [Set Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dump -> Dump -> Set Integer
differing Dump
d) [Dump]
cs)
      [] -> Set Integer
forall a. Set a
S.empty
    differing :: Dump -> Dump -> Set Integer
differing Dump
a Dump
b = [Integer] -> Set Integer
forall a. Ord a => [a] -> Set a
S.fromList
      [ Integer
pc
      | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toList (Map Integer Insn -> Set Integer
forall k a. Map k a -> Set k
M.keysSet (Dump -> Map Integer Insn
dpInsns Dump
a)
                          Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Map Integer Insn -> Set Integer
forall k a. Map k a -> Set k
M.keysSet (Dump -> Map Integer Insn
dpInsns Dump
b))
      , let ia :: Maybe Insn
ia = Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
a)
            ib :: Maybe Insn
ib = Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
b)
            ta :: Maybe (Map Integer Integer)
ta = Integer
-> Map Integer (Map Integer Integer) -> Maybe (Map Integer Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer (Map Integer Integer)
dpTransfers Dump
a)
            tb :: Maybe (Map Integer Integer)
tb = Integer
-> Map Integer (Map Integer Integer) -> Maybe (Map Integer Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer (Map Integer Integer)
dpTransfers Dump
b)
      , (Insn -> (Integer, Text, Text))
-> Maybe Insn -> Maybe (Integer, Text, Text)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Insn -> (Integer, Text, Text)
sig Maybe Insn
ia Maybe (Integer, Text, Text) -> Maybe (Integer, Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Insn -> (Integer, Text, Text))
-> Maybe Insn -> Maybe (Integer, Text, Text)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Insn -> (Integer, Text, Text)
sig Maybe Insn
ib Bool -> Bool -> Bool
|| Maybe (Map Integer Integer)
ta Maybe (Map Integer Integer) -> Maybe (Map Integer Integer) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Map Integer Integer)
tb
          Bool -> Bool -> Bool
|| Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOperands Dump
a) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOperands Dump
b)
          Bool -> Bool -> Bool
|| Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOutside Dump
a) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOutside Dump
b) ]
    sig :: Insn -> (Integer, Text, Text)
sig Insn
i = (Insn -> Integer
inCount Insn
i, Insn -> Text
inFingerprint Insn
i, Insn -> Text
inOrder Insn
i)

    origins :: [(Origin, Insn)]
origins = [ (Origin, Insn)
o | o :: (Origin, Insn)
o@(Origin
_, Insn
i) <- [(Origin, Insn)]
controls [(Origin, Insn)] -> [(Origin, Insn)] -> [(Origin, Insn)]
forall a. Semigroup a => a -> a -> a
<> [(Origin, Insn)]
addresses [(Origin, Insn)] -> [(Origin, Insn)] -> [(Origin, Insn)]
forall a. Semigroup a => a -> a -> a
<> [(Origin, Insn)]
operands
                  , Bool -> Bool
not (Insn -> Integer
inPc Insn
i Integer -> Set Integer -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Integer
unsteady) ]

    -- every run, the declared first
    runs :: [Dump]
runs = [Dump]
ds [Dump] -> [Dump] -> [Dump]
forall a. Semigroup a => a -> a -> a
<> [Dump]
xs

    -- how the runs behaved at an origin: those that ran it, grouped
    -- by what they did there, and those that never ran it. Only the
    -- declared runs speak to an address or an operand.
    behaviourAt :: Origin -> Integer -> ([[Int]], [a])
behaviourAt Origin
o Integer
pc = case Origin
o of
      Origin
ControlOrigin ->
        ( ((Integer, Map Integer Integer, Text)
 -> (Integer, Map Integer Integer, Text) -> Bool)
-> [(Int, (Integer, Map Integer Integer, Text))] -> [[Int]]
forall a. (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes (Integer, Map Integer Integer, Text)
-> (Integer, Map Integer Integer, Text) -> Bool
forall {k} {a} {a}.
(Ord k, Num a, Eq a, Eq a) =>
(a, Map k a, a) -> (a, Map k a, a) -> Bool
outcomesAlike
            [ (Int
k, (Insn -> Integer
inCount Insn
i, Map Integer Integer
-> Integer
-> Map Integer (Map Integer Integer)
-> Map Integer Integer
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Map Integer Integer
forall k a. Map k a
M.empty Integer
pc
                                (Dump -> Map Integer (Map Integer Integer)
dpTransfers Dump
d), Insn -> Text
inOrder Insn
i))
            | (Int
k, Dump
d, Insn
i) <- [Dump] -> [(Int, Dump, Insn)]
forall {a}. (Num a, Enum a) => [Dump] -> [(a, Dump, Insn)]
ranIn [Dump]
runs ]
        , [Dump] -> [a]
forall {a}. (Num a, Enum a) => [Dump] -> [a]
absentIn [Dump]
runs )
      Origin
AddressOrigin ->
        ( (Text -> Text -> Bool) -> [(Int, Text)] -> [[Int]]
forall a. (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) [ (Int
k, Insn -> Text
inFingerprint Insn
i) | (Int
k, Dump
_, Insn
i) <- [Dump] -> [(Int, Dump, Insn)]
forall {a}. (Num a, Enum a) => [Dump] -> [(a, Dump, Insn)]
ranIn [Dump]
ds ]
        , [Dump] -> [a]
forall {a}. (Num a, Enum a) => [Dump] -> [a]
absentIn [Dump]
ds )
      Origin
OperandOrigin ->
        ( (Maybe Text -> Maybe Text -> Bool)
-> [(Int, Maybe Text)] -> [[Int]]
forall a. (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
(==)
            [ (Int
k, Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOperands Dump
d)) | (Int
k, Dump
d, Insn
_) <- [Dump] -> [(Int, Dump, Insn)]
forall {a}. (Num a, Enum a) => [Dump] -> [(a, Dump, Insn)]
ranIn [Dump]
ds ]
        , [Dump] -> [a]
forall {a}. (Num a, Enum a) => [Dump] -> [a]
absentIn [Dump]
ds )
      where
        ranIn :: [Dump] -> [(a, Dump, Insn)]
ranIn [Dump]
rs = [ (a
k, Dump
d, Insn
i) | (a
k, Dump
d) <- [a] -> [Dump] -> [(a, Dump)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ a
0 .. ] [Dump]
rs
                               , Just Insn
i <- [ Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d) ]
                               , Insn -> Integer
inCount Insn
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ]
        absentIn :: [Dump] -> [a]
absentIn [Dump]
rs = [ a
k | (a
k, Dump
d) <- [a] -> [Dump] -> [(a, Dump)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ a
0 .. ] [Dump]
rs
                          , Bool -> (Insn -> Bool) -> Maybe Insn -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (Integer -> Bool) -> (Insn -> Integer) -> Insn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Insn -> Integer
inCount)
                              (Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d)) ]

    pcs :: Set Integer
pcs = [Set Integer] -> Set Integer
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Dump -> Set Integer) -> [Dump] -> [Set Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Integer Insn -> Set Integer
forall k a. Map k a -> Set k
M.keysSet (Map Integer Insn -> Set Integer)
-> (Dump -> Map Integer Insn) -> Dump -> Set Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dump -> Map Integer Insn
dpInsns) [Dump]
runs)
    firstInsn :: Integer -> Maybe Insn
firstInsn Integer
pc = case [ Insn
i | Dump
d <- [Dump]
runs
                            , Just Insn
i <- [ Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d) ] ] of
      (Insn
i : [Insn]
_) -> Insn -> Maybe Insn
forall a. a -> Maybe a
Just Insn
i
      [] -> Maybe Insn
forall a. Maybe a
Nothing

    -- run counts per run, absent counted as never run
    countsIn :: [Dump] -> Integer -> [Integer]
countsIn [Dump]
rs Integer
pc =
      [ Integer -> (Insn -> Integer) -> Maybe Insn -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 Insn -> Integer
inCount (Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d)) | Dump
d <- [Dump]
rs ]
    alike :: [a] -> Bool
alike [a]
ys = case [a]
ys of
      [] -> Bool
True
      (a
y : [a]
rest) -> (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y) [a]
rest

    -- run equally often in every run, and in every declared run
    steady :: Set Integer
steady = (Integer -> Bool) -> Set Integer -> Set Integer
forall a. (a -> Bool) -> Set a -> Set a
S.filter ([Integer] -> Bool
forall {a}. Eq a => [a] -> Bool
alike ([Integer] -> Bool) -> (Integer -> [Integer]) -> Integer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dump] -> Integer -> [Integer]
countsIn [Dump]
runs) Set Integer
pcs
    steadyDeclared :: Set Integer
steadyDeclared = (Integer -> Bool) -> Set Integer -> Set Integer
forall a. (a -> Bool) -> Set a -> Set a
S.filter ([Integer] -> Bool
forall {a}. Eq a => [a] -> Bool
alike ([Integer] -> Bool) -> (Integer -> [Integer]) -> Integer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dump] -> Integer -> [Integer]
countsIn [Dump]
ds)
      ([Set Integer] -> Set Integer
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Dump -> Set Integer) -> [Dump] -> [Set Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Integer Insn -> Set Integer
forall k a. Map k a -> Set k
M.keysSet (Map Integer Insn -> Set Integer)
-> (Dump -> Map Integer Insn) -> Dump -> Set Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dump -> Map Integer Insn
dpInsns) [Dump]
ds))

    -- an instruction's run count, transfers, and the order of what
    -- followed it, in each run that ran it
    ranAt :: Integer -> [(Integer, Map Integer Integer, Text)]
ranAt Integer
pc =
      [ ( Insn -> Integer
inCount Insn
i, Map Integer Integer
-> Integer
-> Map Integer (Map Integer Integer)
-> Map Integer Integer
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Map Integer Integer
forall k a. Map k a
M.empty Integer
pc (Dump -> Map Integer (Map Integer Integer)
dpTransfers Dump
d)
        , Insn -> Text
inOrder Insn
i )
      | Dump
d <- [Dump]
runs, Just Insn
i <- [ Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d) ]
      , Insn -> Integer
inCount Insn
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ]
    transferSources :: Set Integer
transferSources = [Set Integer] -> Set Integer
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Dump -> Set Integer) -> [Dump] -> [Set Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Integer (Map Integer Integer) -> Set Integer
forall k a. Map k a -> Set k
M.keysSet (Map Integer (Map Integer Integer) -> Set Integer)
-> (Dump -> Map Integer (Map Integer Integer))
-> Dump
-> Set Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dump -> Map Integer (Map Integer Integer)
dpTransfers) [Dump]
runs)

    -- outcomes in the same proportion: each target taken as often,
    -- relative to the run count, in both
    proportional :: (a, Map k a) -> (a, Map k a) -> Bool
proportional (a
c, Map k a
ts) (a
c', Map k a
ts') =
      Map k a -> Set k
forall k a. Map k a -> Set k
M.keysSet Map k a
ts Set k -> Set k -> Bool
forall a. Eq a => a -> a -> Bool
== Map k a -> Set k
forall k a. Map k a -> Set k
M.keysSet Map k a
ts'
        Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Map k Bool -> [Bool]
forall k a. Map k a -> [a]
M.elems ((a -> a -> Bool) -> Map k a -> Map k a -> Map k Bool
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (\a
e a
e' -> a
e a -> a -> a
forall a. Num a => a -> a -> a
* a
c' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e' a -> a -> a
forall a. Num a => a -> a -> a
* a
c)
                           Map k a
ts Map k a
ts'))
    -- outcomes alike: each target taken in the same proportion and,
    -- where it ran as often, in the same order
    outcomesAlike :: (a, Map k a, a) -> (a, Map k a, a) -> Bool
outcomesAlike (a
c, Map k a
ts, a
o) (a
c', Map k a
ts', a
o') =
      (a, Map k a) -> (a, Map k a) -> Bool
forall {k} {a}.
(Ord k, Eq a, Num a) =>
(a, Map k a) -> (a, Map k a) -> Bool
proportional (a
c, Map k a
ts) (a
c', Map k a
ts') Bool -> Bool -> Bool
&& (a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c' Bool -> Bool -> Bool
|| a
o a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
o')
    divergent :: Integer -> Bool
divergent Integer
pc = case Integer -> [(Integer, Map Integer Integer, Text)]
ranAt Integer
pc of
      ((Integer, Map Integer Integer, Text)
r : [(Integer, Map Integer Integer, Text)]
rest) -> Bool -> Bool
not (((Integer, Map Integer Integer, Text) -> Bool)
-> [(Integer, Map Integer Integer, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Integer, Map Integer Integer, Text)
-> (Integer, Map Integer Integer, Text) -> Bool
forall {k} {a} {a}.
(Ord k, Num a, Eq a, Eq a) =>
(a, Map k a, a) -> (a, Map k a, a) -> Bool
outcomesAlike (Integer, Map Integer Integer, Text)
r) [(Integer, Map Integer Integer, Text)]
rest)
      [] -> Bool
False

    -- a return goes where its call sent it: downstream, never an
    -- origin, whatever its outcomes
    returns :: Set Integer
returns = [Set Integer] -> Set Integer
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Dump -> Set Integer) -> [Dump] -> [Set Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dump -> Set Integer
dpReturns [Dump]
runs)
    divergentPcs :: Set Integer
divergentPcs = (Integer -> Bool) -> Set Integer -> Set Integer
forall a. (a -> Bool) -> Set a -> Set a
S.filter Integer -> Bool
divergent Set Integer
transferSources
    controlPcs :: Set Integer
controlPcs = Set Integer
divergentPcs Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Integer
returns
    -- the address and operand origins
    dataPcs :: Set Integer
dataPcs = [Integer] -> Set Integer
forall a. Ord a => [a] -> Set a
S.fromList [ Insn -> Integer
inPc Insn
i | (Origin
_, Insn
i) <- [(Origin, Insn)]
addresses [(Origin, Insn)] -> [(Origin, Insn)] -> [(Origin, Insn)]
forall a. Semigroup a => a -> a -> a
<> [(Origin, Insn)]
operands ]
    downstream :: Set Integer
downstream =
      ((((Set Integer
pcs Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Integer
steady)
          Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Set Integer
divergentPcs Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Integer
returns))
          Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Integer
controlPcs)
        Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Integer
dataPcs)
      Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` [Integer] -> Set Integer
forall a. Ord a => [a] -> Set a
S.fromList ((Insn -> Integer) -> [Insn] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Insn -> Integer
inPc [Insn]
outside)

    controls :: [(Origin, Insn)]
controls =
      [ (Origin
ControlOrigin, Insn
i)
      | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
controlPcs
      , Just Insn
i <- [ Integer -> Maybe Insn
firstInsn Integer
pc ] ]

    addresses :: [(Origin, Insn)]
addresses =
      [ (Origin
AddressOrigin, Insn
i)
      | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
steadyDeclared
      , let fps :: [Maybe Text]
fps = [ (Insn -> Text) -> Maybe Insn -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Insn -> Text
inFingerprint (Integer -> Map Integer Insn -> Maybe Insn
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Insn
dpInsns Dump
d))
                  | Dump
d <- [Dump]
ds ]
      , Bool -> Bool
not ([Maybe Text] -> Bool
forall {a}. Eq a => [a] -> Bool
alike [Maybe Text]
fps)
      , Just Insn
i <- [ Integer -> Maybe Insn
firstInsn Integer
pc ]
      , Insn -> Integer
inAccesses Insn
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
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 :: [Insn]
outside =
      [ Insn
i
      | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
steadyDeclared
      , Bool -> Bool
not (Integer
pc Integer -> Set Integer -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Integer
unsteady)
      , Bool -> Bool
not (Integer
pc Integer -> Set Integer -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Integer
controlPcs)
      , Bool -> Bool
not (Integer
pc Integer -> Set Integer -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Integer
dataPcs)
      , let fps :: [Maybe Text]
fps = [ Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOutside Dump
d) | Dump
d <- [Dump]
ds ]
      , (Maybe Text -> Bool) -> [Maybe Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
forall a. Maybe a
Nothing) [Maybe Text]
fps
      , Bool -> Bool
not ([Maybe Text] -> Bool
forall {a}. Eq a => [a] -> Bool
alike [Maybe Text]
fps)
      , Just Insn
i <- [ Integer -> Maybe Insn
firstInsn Integer
pc ] ]

    -- a division run equally often in every declared run, on other
    -- operands in one
    operands :: [(Origin, Insn)]
operands =
      [ (Origin
OperandOrigin, Insn
i)
      | Integer
pc <- Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
steadyDeclared
      , let fps :: [Maybe Text]
fps = [ Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Integer
pc (Dump -> Map Integer Text
dpOperands Dump
d) | Dump
d <- [Dump]
ds ]
      , (Maybe Text -> Bool) -> [Maybe Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
forall a. Maybe a
Nothing) [Maybe Text]
fps
      , Bool -> Bool
not ([Maybe Text] -> Bool
forall {a}. Eq a => [a] -> Bool
alike [Maybe Text]
fps)
      , Just Insn
i <- [ Integer -> Maybe Insn
firstInsn Integer
pc ] ]

-- | Only the origins, what was executed, and what ran downstream, in
--   objects whose path contains one of the given texts.
restrictTo :: [T.Text] -> Divergence -> Divergence
restrictTo :: [Text] -> Divergence -> Divergence
restrictTo [Text]
ps Divergence
dv
  | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
ps = Divergence
dv
  | Bool
otherwise = Divergence
dv {
        dvOrigins = filter (inside . inObject . snd) (dvOrigins dv)
      , dvDownstream = filter (inside . inObject) (dvDownstream dv)
      , dvExecuted = M.filterWithKey (\Text
o Set Integer
_ -> Maybe Text -> Bool
inside (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
o))
          (dvExecuted dv)
      , dvOutside = filter (inside . inObject) (dvOutside dv)
      , dvWatched = M.filterWithKey (\Text
o Set Integer
_ -> Maybe Text -> Bool
inside (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
o))
          (dvWatched dv)
      }
  where
    inside :: Maybe Text -> Bool
inside Maybe Text
mo = case Maybe Text
mo of
      Just Text
o -> (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isInfixOf` Text
o) [Text]
ps
      Maybe Text
Nothing -> Bool
False

originText :: Origin -> T.Text
originText :: Origin -> Text
originText Origin
o = case Origin
o of
  Origin
ControlOrigin -> Text
"control"
  Origin
AddressOrigin -> Text
"address"
  Origin
OperandOrigin -> Text
"operand"

-- | 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. The ISA, contract, and CPU model 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 :: Text
-> [Named] -> Map (Text, Integer) [Place] -> Divergence -> Value
divergenceJson Text
version [Named]
runs Map (Text, Integer) [Place]
places Divergence
dv = [(Text, Value)] -> Value
Object
  [ (Text
"schema", Text -> Value
String Text
"vestigia/diff-v4")
  , (Text
"tool", [(Text, Value)] -> Value
Object [ (Text
"name", Text -> Value
String Text
"vestigia")
                    , (Text
"version", Text -> Value
String Text
version) ])
  , (Text
"isa", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Divergence -> Maybe Text
dvIsa Divergence
dv))
  , (Text
"contract", case Divergence -> Maybe Text
dvContract Divergence
dv of
      Just Text
n -> [(Text, Value)] -> Value
Object
        [ (Text
"name", Text -> Value
String Text
n)
        , (Text
"source", Value -> (Contract -> Value) -> Maybe Contract -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Text -> Value
String (Text -> Value) -> (Contract -> Text) -> Contract -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contract -> Text
contractSource)
            (Text -> Maybe Contract
readContract Text
n)) ]
      Maybe Text
Nothing -> Value
Null)
  , (Text
"cpu", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Divergence -> Maybe Text
dvCpu Divergence
dv))
  , (Text
"runs", [Value] -> Value
Array
      [ [(Text, Value)] -> Value
Object
          [ (Text
"name", Text -> Value
String (Named -> Text
nmName Named
r))
          , (Text
"kind", Text -> Value
String (Kind -> Text
forall {a}. IsString a => Kind -> a
kindText (Named -> Kind
nmKind Named
r)))
          , (Text
"arguments", [Value] -> Value
Array
              [ Text -> Value
String (OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
a)
              | ByteString
a <- Run -> [ByteString]
rnArguments (Named -> Run
nmRun Named
r) ])
          , (Text
"status", Integer -> Value
Number (Run -> Integer
rnStatus (Named -> Run
nmRun Named
r)))
          ]
      | Named
r <- [Named]
runs ])
  , (Text
"summary", [(Text, Value)] -> Value
Object
      [ (Text
"control", Origin -> Value
count Origin
ControlOrigin)
      , (Text
"address", Origin -> Value
count Origin
AddressOrigin)
      , (Text
"operand", Origin -> Value
count Origin
OperandOrigin)
      , (Text
"downstream", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Insn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [Insn]
dvDownstream Divergence
dv))))
      , (Text
"unsteady", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Insn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [Insn]
dvUnsteady Divergence
dv))))
      , (Text
"outside", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Insn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [Insn]
dvOutside Divergence
dv))))
      , (Text
"watched", Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Set Integer -> Int) -> [Set Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Integer -> Int
forall a. Set a -> Int
S.size
          (Map Text (Set Integer) -> [Set Integer]
forall k a. Map k a -> [a]
M.elems (Divergence -> Map Text (Set Integer)
dvWatched Divergence
dv))))))
      ])
  , (Text
"origins", [Value] -> Value
Array
      [ Text -> Insn -> ([[Int]], [Int]) -> Value
site (Origin -> Text
originText Origin
o) Insn
i
          (([[Int]], [Int])
-> (Origin, Integer)
-> Map (Origin, Integer) ([[Int]], [Int])
-> ([[Int]], [Int])
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([], []) (Origin
o, Insn -> Integer
inPc Insn
i) (Divergence -> Map (Origin, Integer) ([[Int]], [Int])
dvBehaviour Divergence
dv))
      | (Origin
o, Insn
i) <- Divergence -> [(Origin, Insn)]
dvOrigins Divergence
dv ])
  , (Text
"outside", [Value] -> Value
Array
      [ Text -> Insn -> ([[Int]], [Int]) -> Value
site Text
"outside" Insn
i
          (([[Int]], [Int])
-> Integer -> Map Integer ([[Int]], [Int]) -> ([[Int]], [Int])
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([], []) (Insn -> Integer
inPc Insn
i) (Divergence -> Map Integer ([[Int]], [Int])
dvOutsideBehaviour Divergence
dv))
      | Insn
i <- Divergence -> [Insn]
dvOutside Divergence
dv ])
  , (Text
"downstream", [(Text, Value)] -> Value
Object
      [ (Text
obj, [Value] -> Value
Array ((Integer -> Value) -> [Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Value
String (Text -> Value) -> (Integer -> Text) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
hex) (Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
offs)))
      | (Text
obj, Set Integer
offs) <- Map Text (Set Integer) -> [(Text, Set Integer)]
forall k a. Map k a -> [(k, a)]
M.toList ((Set Integer -> Set Integer -> Set Integer)
-> [(Text, Set Integer)] -> Map Text (Set Integer)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set Integer -> Set Integer -> Set Integer
forall a. Ord a => Set a -> Set a -> Set a
S.union
          [ (Text
obj, Integer -> Set Integer
forall a. a -> Set a
S.singleton (Insn -> Integer
inOffset Insn
i))
          | Insn
i <- Divergence -> [Insn]
dvDownstream Divergence
dv, Just Text
obj <- [ Insn -> Maybe Text
inObject Insn
i ] ]) ])
  , (Text
"unsteady", [Insn] -> Value
byObject (Divergence -> [Insn]
dvUnsteady Divergence
dv))
  , (Text
"executed", [(Text, Value)] -> Value
Object
      [ (Text
o, [Value] -> Value
Array ((Integer -> Value) -> [Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Value
String (Text -> Value) -> (Integer -> Text) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
hex) (Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
xs)))
      | (Text
o, Set Integer
xs) <- Map Text (Set Integer) -> [(Text, Set Integer)]
forall k a. Map k a -> [(k, a)]
M.toList (Divergence -> Map Text (Set Integer)
dvExecuted Divergence
dv) ])
  , (Text
"watched", [(Text, Value)] -> Value
Object
      [ (Text
o, [Value] -> Value
Array ((Integer -> Value) -> [Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Value
String (Text -> Value) -> (Integer -> Text) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
hex) (Set Integer -> [Integer]
forall a. Set a -> [a]
S.toAscList Set Integer
xs)))
      | (Text
o, Set Integer
xs) <- Map Text (Set Integer) -> [(Text, Set Integer)]
forall k a. Map k a -> [(k, a)]
M.toList (Divergence -> Map Text (Set Integer)
dvWatched Divergence
dv) ])
  ]
  where
    site :: Text -> Insn -> ([[Int]], [Int]) -> Value
site Text
cls Insn
i ([[Int]]
groups, [Int]
absent) =
      let ([[(Maybe Text, Integer)]]
stacks, Bool
partial) = ([[(Maybe Text, Integer)]], Bool)
-> Integer
-> Map Integer ([[(Maybe Text, Integer)]], Bool)
-> ([[(Maybe Text, Integer)]], Bool)
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([], Bool
False) (Insn -> Integer
inPc Insn
i)
            (Divergence -> Map Integer ([[(Maybe Text, Integer)]], Bool)
dvCallers Divergence
dv)
      in [(Text, Value)] -> Value
Object
           [ (Text
"class", Text -> Value
String Text
cls)
           , (Text
"pc", Text -> Value
String (Integer -> Text
hex (Insn -> Integer
inPc Insn
i)))
           , (Text
"object", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Insn -> Maybe Text
inObject Insn
i))
           , (Text
"offset", Text -> Value
String (Integer -> Text
hex (Insn -> Integer
inOffset Insn
i)))
           , (Text
"count", Integer -> Value
Number (Insn -> Integer
inCount Insn
i))
           , (Text
"instruction", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String
               (Integer -> Map Integer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Insn -> Integer
inPc Insn
i) (Divergence -> Map Integer Text
dvTexts Divergence
dv)))
           , (Text
"frames", [Value] -> Value
Array ((Place -> Value) -> [Place] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Place -> Value
placeJson (Insn -> [Place]
placesOf Insn
i)))
           , (Text
"stacks", [Value] -> Value
Array
               [ [Value] -> Value
Array ((Maybe Text, Integer) -> [Value]
located (Insn -> Maybe Text
inObject Insn
i, Insn -> Integer
inOffset Insn
i)
                          [Value] -> [Value] -> [Value]
forall a. Semigroup a => a -> a -> a
<> ((Maybe Text, Integer) -> [Value])
-> [(Maybe Text, Integer)] -> [Value]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Text, Integer) -> [Value]
located [(Maybe Text, Integer)]
calls)
               | [(Maybe Text, Integer)]
calls <- [[(Maybe Text, Integer)]]
stacks ])
           , (Text
"partial", Bool -> Value
Bool Bool
partial)
           , (Text
"groups", [Value] -> Value
Array (([Int] -> Value) -> [[Int]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Value] -> Value
Array ([Value] -> Value) -> ([Int] -> [Value]) -> [Int] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Value
named) [[Int]]
groups))
           , (Text
"absent", [Value] -> Value
Array ((Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Value
named [Int]
absent))
           ]
    names :: [Text]
names = [ Named -> Text
nmName Named
r | Named
r <- [Named]
runs, Named -> Kind
nmKind Named
r Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
/= Kind
ControlRun ]
    kindText :: Kind -> a
kindText Kind
k = case Kind
k of
      Kind
DeclaredRun -> a
"declared"
      Kind
DesignedRun -> a
"designed"
      Kind
ControlRun -> a
"control"
    count :: Origin -> Value
count Origin
o = Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
      [ () | (Origin
o', Insn
_) <- Divergence -> [(Origin, Insn)]
dvOrigins Divergence
dv, Origin
o' Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
o ]))
    named :: Int -> Value
named Int
k = case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
k [Text]
names of
      (Text
n : [Text]
_) -> Text -> Value
String Text
n
      [] -> Text -> Value
String (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
k))
    byObject :: [Insn] -> Value
byObject [Insn]
is = [(Text, Value)] -> Value
Object
      [ (Text
o, Integer -> Value
Number (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n))
      | (Text
o, Int
n) <- Map Text Int -> [(Text, Int)]
forall k a. Map k a -> [(k, a)]
M.toList ((Int -> Int -> Int) -> [(Text, Int)] -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
          [ (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"-" Text -> Text
forall a. a -> a
id (Insn -> Maybe Text
inObject Insn
i), Int
1 :: Int) | Insn
i <- [Insn]
is ]) ]
    placesOf :: Insn -> [Place]
placesOf Insn
i = case Insn -> Maybe Text
inObject Insn
i of
      Just Text
obj -> [Place]
-> (Text, Integer) -> Map (Text, Integer) [Place] -> [Place]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] (Text
obj, Insn -> Integer
inOffset Insn
i) Map (Text, Integer) [Place]
places
      Maybe Text
Nothing -> []
    placeJson :: Place -> Value
placeJson Place
p = [(Text, Value)] -> Value
Object
      [ (Text
"function", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Place -> Maybe Text
plFunction Place
p))
      , (Text
"file", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String (Place -> Maybe Text
plFile Place
p))
      , (Text
"line", Value -> (Int -> Value) -> Maybe Int -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Integer -> Value
Number (Integer -> Value) -> (Int -> Integer) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) (Place -> Maybe Int
plLine Place
p))
      ]
    -- an instruction's frames, innermost first, each with where the
    -- instruction is; one unnamed frame where nothing names it
    located :: (Maybe Text, Integer) -> [Value]
located (Maybe Text
mo, Integer
a) =
      let at :: [(Text, Value)]
at = [ (Text
"object", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null Text -> Value
String Maybe Text
mo)
               , (Text
"offset", Text -> Value
String (Integer -> Text
hex Integer
a)) ]
          ps :: [Place]
ps = case Maybe Text
mo of
            Just Text
obj -> [Place]
-> (Text, Integer) -> Map (Text, Integer) [Place] -> [Place]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] (Text
obj, Integer
a) Map (Text, Integer) [Place]
places
            Maybe Text
Nothing -> []
      in case [Place]
ps of
           [] -> [ [(Text, Value)] -> Value
Object ([(Text, Value)]
at [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"function", Value
Null), (Text
"file", Value
Null)
                                 , (Text
"line", Value
Null) ]) ]
           [Place]
_ -> [ case Place -> Value
placeJson Place
p of
                    Object [(Text, Value)]
kvs -> [(Text, Value)] -> Value
Object ([(Text, Value)]
at [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Value)]
kvs)
                    Value
other -> Value
other
                | Place
p <- [Place]
ps ]

-- | One line per origin, innermost frame first, for a terminal.
divergenceSummary
  :: M.Map (T.Text, Integer) [Place] -> Divergence -> T.Text
divergenceSummary :: Map (Text, Integer) [Place] -> Divergence -> Text
divergenceSummary Map (Text, Integer) [Place]
places Divergence
dv = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
  [ Text -> [Text] -> Text
T.intercalate Text
"  "
      [ Text
cls
      , Integer -> Text
hex (Insn -> Integer
inOffset Insn
i)
      , Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" Text -> Text
forall a. a -> a
id (Place -> Maybe Text
plFunction (Place -> Maybe Text) -> Maybe Place -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Insn -> Maybe Place
innermost Insn
i)
      , Text -> (Place -> Text) -> Maybe Place -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" Place -> Text
location (Insn -> Maybe Place
innermost Insn
i)
      , Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"-" Text -> Text
base (Insn -> Maybe Text
inObject Insn
i) ]
  | (Text
cls, Insn
i) <- [ (Origin -> Text
originText Origin
o, Insn
i) | (Origin
o, Insn
i) <- Divergence -> [(Origin, Insn)]
dvOrigins Divergence
dv ]
                  [(Text, Insn)] -> [(Text, Insn)] -> [(Text, Insn)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"outside", Insn
i) | Insn
i <- Divergence -> [Insn]
dvOutside Divergence
dv ] ]
  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([(Origin, Insn)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [(Origin, Insn)]
dvOrigins Divergence
dv))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" origin(s) over "
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Divergence -> Int
dvRuns Divergence
dv)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" run(s)"
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Divergence -> Int
dvDesigned Divergence
dv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
""
           else Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Divergence -> Int
dvDesigned Divergence
dv)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" designed")
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; "
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([Insn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [Insn]
dvDownstream Divergence
dv)))
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" instruction(s) downstream; "
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([Insn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [Insn]
dvUnsteady Divergence
dv)))
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" unsteady over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Divergence -> Int
dvControls Divergence
dv))
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" control(s)"
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
""
            (\Text
c -> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
watched)
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" instruction(s) outside " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ran, "
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([Insn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Divergence -> [Insn]
dvOutside Divergence
dv)))
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on operands that differed")
            (Divergence -> Maybe Text
dvContract Divergence
dv) ]
  where
    watched :: Int
watched = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Set Integer -> Int) -> [Set Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Integer -> Int
forall a. Set a -> Int
S.size (Map Text (Set Integer) -> [Set Integer]
forall k a. Map k a -> [a]
M.elems (Divergence -> Map Text (Set Integer)
dvWatched Divergence
dv)))
    innermost :: Insn -> Maybe Place
innermost Insn
i = case Insn -> Maybe Text
inObject Insn
i of
      Just Text
obj -> case [Place]
-> (Text, Integer) -> Map (Text, Integer) [Place] -> [Place]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] (Text
obj, Insn -> Integer
inOffset Insn
i) Map (Text, Integer) [Place]
places of
        (Place
p : [Place]
_) -> Place -> Maybe Place
forall a. a -> Maybe a
Just Place
p
        [] -> Maybe Place
forall a. Maybe a
Nothing
      Maybe Text
Nothing -> Maybe Place
forall a. Maybe a
Nothing
    location :: Place -> Text
location Place
p = case (Place -> Maybe Text
plFile Place
p, Place -> Maybe Int
plLine Place
p) of
      (Just Text
f, Just Int
l) -> Text -> Text
base Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
l)
      (Just Text
f, Maybe Int
Nothing) -> Text -> Text
base Text
f
      (Maybe Text, Maybe Int)
_ -> Text
"?"
    base :: Text -> Text
base Text
p = case [Text] -> [Text]
forall a. [a] -> [a]
reverse (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
p) of
      (Text
x : [Text]
_) -> Text
x
      [] -> Text
p

hex :: Integer -> T.Text
hex :: Integer -> Text
hex Integer
n = Text
"0x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex Integer
n String
"")

-- keys grouped by an equivalence on their values, each group in
-- order and the groups by their first member
classes :: (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes :: forall a. (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes a -> a -> Bool
eq [(Int, a)]
ys = case [(Int, a)]
ys of
  [] -> []
  ((Int
k, a
y) : [(Int, a)]
rest) ->
    let ([(Int, a)]
same, [(Int, a)]
other) = ((Int, a) -> Bool) -> [(Int, a)] -> ([(Int, a)], [(Int, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (a -> a -> Bool
eq a
y (a -> Bool) -> ((Int, a) -> a) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd) [(Int, a)]
rest
    in (Int
k Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((Int, a) -> Int) -> [(Int, a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, a) -> Int
forall a b. (a, b) -> a
fst [(Int, a)]
same) [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
forall a. (a -> a -> Bool) -> [(Int, a)] -> [[Int]]
classes a -> a -> Bool
eq [(Int, a)]
other