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

-- |
-- Module: Vestigia.Contract
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- An ISA's data-independent-timing contract, and what it makes of
-- each instruction of an object: one it covers takes a time
-- independent of its data; one it does not, run on operands that
-- depend on the secret, is outside the contract; and a division is
-- variable-time on either ISA. Control flow and system instructions
-- are left to the comparison of what ran.
--
-- An object is read through LLVM's disassembler (@llvm-objdump@), in
-- Intel syntax on x86_64. On AArch64 an instruction is matched by its
-- encoding against Arm's own ('Vestigia.Contract.Arm'), its source
-- registers read off the fields the encoding names. On x86_64 it is
-- matched by its mnemonic and opcode byte against Intel's list
-- ('Vestigia.Contract.Intel'), its source registers read off its
-- operands: every register operand outside a memory reference, but
-- the first where the instruction only writes it, and the registers
-- some instructions read without naming.
--
-- What is outside the contract and reads data becomes the watch
-- list the QEMU plugin is given: each such instruction, by its
-- address in its object, with the registers to fingerprint before it
-- runs, as the plugin fingerprints a division's operands.

module Vestigia.Contract (
    Contract(..)
  , contractName
  , contractSource
  , contractIsa
  , readContract
  , Line(..)
  , readDisassembly
  , Register(..)
  , Verdict(..)
  , classify
  , watchSection
  ) where

import Data.Bits (popCount, shiftR, testBit, (.&.))
import Data.Char (isHexDigit)
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 Data.Word (Word32, Word8)
import Numeric (readHex, showHex)

import qualified Vestigia.Contract.Arm as Arm
import qualified Vestigia.Contract.Intel as Intel
import Vestigia.Contract.Types

-- | A data-independent-timing contract: Arm's @PSTATE.DIT@, or
--   Intel's DOITM.
data Contract =
    ArmDit
  | IntelDoitm
  deriving (Contract -> Contract -> Bool
(Contract -> Contract -> Bool)
-> (Contract -> Contract -> Bool) -> Eq Contract
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Contract -> Contract -> Bool
== :: Contract -> Contract -> Bool
$c/= :: Contract -> Contract -> Bool
/= :: Contract -> Contract -> Bool
Eq, Int -> Contract -> ShowS
[Contract] -> ShowS
Contract -> String
(Int -> Contract -> ShowS)
-> (Contract -> String) -> ([Contract] -> ShowS) -> Show Contract
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Contract -> ShowS
showsPrec :: Int -> Contract -> ShowS
$cshow :: Contract -> String
show :: Contract -> String
$cshowList :: [Contract] -> ShowS
showList :: [Contract] -> ShowS
Show)

contractName :: Contract -> T.Text
contractName :: Contract -> Text
contractName Contract
c = case Contract
c of
  Contract
ArmDit -> Text
"arm-dit"
  Contract
IntelDoitm -> Text
"intel-doitm"

-- | The release of the vendor's own statement the table transcribes.
contractSource :: Contract -> T.Text
contractSource :: Contract -> Text
contractSource Contract
c = case Contract
c of
  Contract
ArmDit -> Text
"Arm A64 ISA XML, 2022-12"
  Contract
IntelDoitm -> Text
"Intel 768547, Table 1, 2026-02-23"

-- | The ISA a contract speaks to, as QEMU names it.
contractIsa :: Contract -> String
contractIsa :: Contract -> String
contractIsa Contract
c = case Contract
c of
  Contract
ArmDit -> String
"aarch64"
  Contract
IntelDoitm -> String
"x86_64"

readContract :: T.Text -> Maybe Contract
readContract :: Text -> Maybe Contract
readContract Text
t = case Text
t of
  Text
"arm-dit" -> Contract -> Maybe Contract
forall a. a -> Maybe a
Just Contract
ArmDit
  Text
"intel-doitm" -> Contract -> Maybe Contract
forall a. a -> Maybe a
Just Contract
IntelDoitm
  Text
_ -> Maybe Contract
forall a. Maybe a
Nothing

-- | One instruction as the disassembler prints it: its address in
--   the object, its raw form (an AArch64 word, or x86_64's bytes),
--   any prefixes, its mnemonic, and its operands.
data Line = Line {
    Line -> Integer
lnAddress :: !Integer
  , Line -> [Integer]
lnRaw :: ![Integer]
  , Line -> [Text]
lnPrefixes :: ![T.Text]
  , Line -> Text
lnMnemonic :: !T.Text
  , Line -> Text
lnOperands :: !T.Text
  } deriving (Line -> Line -> Bool
(Line -> Line -> Bool) -> (Line -> Line -> Bool) -> Eq Line
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
/= :: Line -> Line -> Bool
Eq, Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Line -> ShowS
showsPrec :: Int -> Line -> ShowS
$cshow :: Line -> String
show :: Line -> String
$cshowList :: [Line] -> ShowS
showList :: [Line] -> ShowS
Show)

-- | The instructions of @llvm-objdump@'s disassembly; everything
--   else it prints (headers, symbols, elided runs) is passed over.
readDisassembly :: T.Text -> [Line]
readDisassembly :: Text -> [Line]
readDisassembly = (Text -> [Line]) -> [Text] -> [Line]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Line]
line ([Text] -> [Line]) -> (Text -> [Text]) -> Text -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
  where
    line :: Text -> [Line]
line Text
l = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
":" (Text -> Text
T.stripStart Text
l) of
      (Text
a, Text
rest)
        | Bool -> Bool
not (Text -> Bool
T.null Text
a), (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
a
        , Just Text
body <- Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
rest
        , [ (Integer
addr, String
"") ] <- ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
a)
        , (Text
raw, Text
text) <- HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"\t" Text
body
        , Just [Integer]
ws <- (Text -> Maybe Integer) -> [Text] -> Maybe [Integer]
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 Text -> Maybe Integer
forall {a}. (Eq a, Num a) => Text -> Maybe a
hexToken (Text -> [Text]
T.words Text
raw)
        , Bool -> Bool
not ([Integer] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Integer]
ws) ->
            case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)
                   ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\t" Text
text)) of
              [] -> []
              [Text]
fs -> let ([Text]
ps, [Text]
rest') = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
prefixes) [Text]
fs
                    in case [Text]
rest' of
                         (Text
m : [Text]
ops) -> [ Integer -> [Integer] -> [Text] -> Text -> Text -> Line
Line Integer
addr [Integer]
ws [Text]
ps Text
m
                                          (Text -> Text
uncomment ([Text] -> Text
T.unwords [Text]
ops)) ]
                         [] -> []
      (Text, Text)
_ -> []
    hexToken :: Text -> Maybe a
hexToken Text
w
      | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
w, [ (a
v, String
"") ] <- ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
w) = a -> Maybe a
forall a. a -> Maybe a
Just a
v
      | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
    -- the disassembler's annotations, x86_64's after " # " and
    -- AArch64's after " //": a target or a literal, never an operand
    -- (an AArch64 immediate is "#" with no space after it)
    uncomment :: Text -> Text
uncomment Text
t =
      Text -> Text
T.stripEnd ((Text, Text) -> Text
forall a b. (a, b) -> a
fst (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
" //" ((Text, Text) -> Text
forall a b. (a, b) -> a
fst (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
" # " Text
t))))

-- prefixes the disassembler prints as fields of their own
prefixes :: S.Set T.Text
prefixes :: Set Text
prefixes = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList
  [ Text
"lock", Text
"rep", Text
"repe", Text
"repz", Text
"repne", Text
"repnz", Text
"data16", Text
"data32"
  , Text
"addr32", Text
"notrack", Text
"bnd", Text
"xacquire", Text
"xrelease", Text
"cs", Text
"ds"
  , Text
"es", Text
"fs", Text
"gs", Text
"ss" ]

-- | A register to fingerprint, as QEMU names it, by the bits read:
--   from its low bit, so many of them.
data Register = Register {
    Register -> Text
rgName :: !T.Text
  , Register -> Int
rgLow :: !Int
  , Register -> Int
rgWidth :: !Int
  } deriving (Register -> Register -> Bool
(Register -> Register -> Bool)
-> (Register -> Register -> Bool) -> Eq Register
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Register -> Register -> Bool
== :: Register -> Register -> Bool
$c/= :: Register -> Register -> Bool
/= :: Register -> Register -> Bool
Eq, Eq Register
Eq Register =>
(Register -> Register -> Ordering)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Bool)
-> (Register -> Register -> Register)
-> (Register -> Register -> Register)
-> Ord Register
Register -> Register -> Bool
Register -> Register -> Ordering
Register -> Register -> Register
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 :: Register -> Register -> Ordering
compare :: Register -> Register -> Ordering
$c< :: Register -> Register -> Bool
< :: Register -> Register -> Bool
$c<= :: Register -> Register -> Bool
<= :: Register -> Register -> Bool
$c> :: Register -> Register -> Bool
> :: Register -> Register -> Bool
$c>= :: Register -> Register -> Bool
>= :: Register -> Register -> Bool
$cmax :: Register -> Register -> Register
max :: Register -> Register -> Register
$cmin :: Register -> Register -> Register
min :: Register -> Register -> Register
Ord, Int -> Register -> ShowS
[Register] -> ShowS
Register -> String
(Int -> Register -> ShowS)
-> (Register -> String) -> ([Register] -> ShowS) -> Show Register
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Register -> ShowS
showsPrec :: Int -> Register -> ShowS
$cshow :: Register -> String
show :: Register -> String
$cshowList :: [Register] -> ShowS
showList :: [Register] -> ShowS
Show)

-- | What a contract makes of an instruction: covered by it; control
--   flow or system, or reading no data; an integer division, which
--   the plugin reads for itself; or outside the contract, with the
--   registers it reads and whether it names memory.
data Verdict =
    Inside
  | Excluded
  | Division
  | Watched ![Register] !Bool
  deriving (Verdict -> Verdict -> Bool
(Verdict -> Verdict -> Bool)
-> (Verdict -> Verdict -> Bool) -> Eq Verdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verdict -> Verdict -> Bool
== :: Verdict -> Verdict -> Bool
$c/= :: Verdict -> Verdict -> Bool
/= :: Verdict -> Verdict -> Bool
Eq, Int -> Verdict -> ShowS
[Verdict] -> ShowS
Verdict -> String
(Int -> Verdict -> ShowS)
-> (Verdict -> String) -> ([Verdict] -> ShowS) -> Show Verdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verdict -> ShowS
showsPrec :: Int -> Verdict -> ShowS
$cshow :: Verdict -> String
show :: Verdict -> String
$cshowList :: [Verdict] -> ShowS
showList :: [Verdict] -> ShowS
Show)

-- | Classify one instruction under a contract.
classify :: Contract -> Line -> Verdict
classify :: Contract -> Line -> Verdict
classify Contract
c Line
l = case Contract
c of
  Contract
ArmDit -> case Line -> [Integer]
lnRaw Line
l of
    [ Integer
w ] | Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0, Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
32 :: Int) -> Word32 -> Line -> Verdict
arm (Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
w) Line
l
    [Integer]
_ -> Verdict
Excluded
  Contract
IntelDoitm -> Line -> Verdict
intel Line
l

-- AArch64 ---------------------------------------------------------

arm :: Word32 -> Line -> Verdict
arm :: Word32 -> Line -> Verdict
arm Word32
w Line
l = case Maybe Encoding
best of
  Maybe Encoding
Nothing -> Verdict
Excluded
  Just Encoding
e
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Encoding -> Text
enName Encoding
e) [ Text
"UDIV_", Text
"SDIV_" ] -> Verdict
Division
    | Bool
otherwise -> case Encoding -> Status
enStatus Encoding
e of
        Status
Covered -> Verdict
Inside
        Status
Control -> Verdict
Excluded
        Outside [(Int, Operand)]
ops -> case ((Int, Operand) -> [Register]) -> [(Int, Operand)] -> [Register]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Word32 -> (Int, Operand) -> [Register]
register Word32
w) [(Int, Operand)]
ops of
          [] | Bool -> Bool
not Bool
memory -> Verdict
Excluded
          [Register]
rs -> [Register] -> Bool -> Verdict
Watched ([Register] -> [Register]
forall a. Eq a => [a] -> [a]
L.nub [Register]
rs) Bool
memory
  where
    memory :: Bool
memory = Text
"[" Text -> Text -> Bool
`T.isInfixOf` Line -> Text
lnOperands Line
l
    candidates :: [Encoding]
candidates = [Encoding] -> Word32 -> Map Word32 [Encoding] -> [Encoding]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] (Word32 -> Word32
bucket Word32
w) Map Word32 [Encoding]
armIndex
    best :: Maybe Encoding
best = case [ Encoding
e | Encoding
e <- [Encoding]
candidates, Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Encoding -> Word32
enMask Encoding
e Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Encoding -> Word32
enValue Encoding
e ] of
      [] -> Maybe Encoding
forall a. Maybe a
Nothing
      [Encoding]
es -> Encoding -> Maybe Encoding
forall a. a -> Maybe a
Just ((Encoding -> Encoding -> Ordering) -> [Encoding] -> Encoding
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
L.maximumBy (\Encoding
a Encoding
b -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Encoding -> Int
fixed Encoding
a) (Encoding -> Int
fixed Encoding
b)) [Encoding]
es)
    fixed :: Encoding -> Int
fixed Encoding
e = Word32 -> Int
forall a. Bits a => a -> Int
popCount (Encoding -> Word32
enMask Encoding
e)

-- an encoding's group, bits 28 to 25
bucket :: Word32 -> Word32
bucket :: Word32 -> Word32
bucket Word32
w = (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
25) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xf

-- the encodings by every group their fixed bits allow
armIndex :: M.Map Word32 [Encoding]
armIndex :: Map Word32 [Encoding]
armIndex = ([Encoding] -> [Encoding] -> [Encoding])
-> [(Word32, [Encoding])] -> Map Word32 [Encoding]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (([Encoding] -> [Encoding] -> [Encoding])
-> [Encoding] -> [Encoding] -> [Encoding]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Encoding] -> [Encoding] -> [Encoding]
forall a. Semigroup a => a -> a -> a
(<>))
  [ (Word32
b, [ Encoding
e ])
  | Encoding
e <- [Encoding]
Arm.encodings
  , Word32
b <- [ Word32
0 .. Word32
15 ]
  , Word32
b Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
bucket (Encoding -> Word32
enMask Encoding
e) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32 -> Word32
bucket (Encoding -> Word32
enValue Encoding
e) ]

register :: Word32 -> (Int, Operand) -> [Register]
register :: Word32 -> (Int, Operand) -> [Register]
register Word32
w (Int
lsb, Operand
op) =
  let n :: Int
n = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
lsb) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
31) :: Int
      x :: Text
x = Text
"x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
      v :: Text
v = Text
"v" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
  in case Operand
op of
       Operand
OpX | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
31 -> []
           | Bool
otherwise -> [ Text -> Int -> Int -> Register
Register Text
x Int
0 Int
64 ]
       Operand
OpXSp | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
31 -> [ Text -> Int -> Int -> Register
Register Text
"sp" Int
0 Int
64 ]
             | Bool
otherwise -> [ Text -> Int -> Int -> Register
Register Text
x Int
0 Int
64 ]
       Operand
OpW | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
31 -> []
           | Bool
otherwise -> [ Text -> Int -> Int -> Register
Register Text
x Int
0 Int
32 ]
       Operand
OpWSp | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
31 -> [ Text -> Int -> Int -> Register
Register Text
"sp" Int
0 Int
32 ]
             | Bool
otherwise -> [ Text -> Int -> Int -> Register
Register Text
x Int
0 Int
32 ]
       Operand
OpQ -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 Int
128 ]
       Operand
OpD -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 Int
64 ]
       Operand
OpS -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 Int
32 ]
       Operand
OpH -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 Int
16 ]
       Operand
OpB -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 Int
8 ]
       Operand
OpV -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 (if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
w Int
30 then Int
128 else Int
64) ]
       Operand
OpVWhole -> [ Text -> Int -> Int -> Register
Register Text
v Int
0 Int
128 ]

-- x86_64 ----------------------------------------------------------

intel :: Line -> Verdict
intel :: Line -> Verdict
intel Line
l
  | Text
m Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
control Bool -> Bool -> Bool
|| Text
"J" Text -> Text -> Bool
`T.isPrefixOf` Text
m = Verdict
Excluded
  | Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"DIV" Bool -> Bool -> Bool
|| Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"IDIV" = Verdict
Division
  | Just Word8
op <- [Integer] -> Maybe Word8
opcode (Line -> [Integer]
lnRaw Line
l)
  , (Text
name, Word8
op) (Text, Word8) -> Set (Text, Word8) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Text, Word8)
intelRows = Verdict
Inside
  | [Register] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Register]
sources Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
memory = Verdict
Excluded
  | Bool
otherwise = [Register] -> Bool -> Verdict
Watched ([Register] -> [Register]
forall a. Eq a => [a] -> [a]
L.nub [Register]
sources) Bool
memory
  where
    m :: Text
m = Line -> Text
mnemonic Line
l
    -- a repeat prefix names a string instruction's row; on any other
    -- it does nothing
    name :: Text
name
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Text
"rep", Text
"repe", Text
"repz", Text
"repne", Text
"repnz" ])
            (Line -> [Text]
lnPrefixes Line
l)
      , (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
m)
          [ Text
"MOVS", Text
"STOS", Text
"LODS", Text
"CMPS", Text
"SCAS", Text
"INS", Text
"OUTS" ] =
          Text
"REP_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m
      | Bool
otherwise = Text
m
    operands :: [Text]
operands = Text -> [Text]
splitOperands (Line -> Text
lnOperands Line
l)
    memory :: Bool
memory = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text
"[" Text -> Text -> Bool
`T.isInfixOf`) [Text]
operands
    named :: [Register]
named = [ Register
r | Text
o <- [Text]
operands, Bool -> Bool
not (Text
"[" Text -> Text -> Bool
`T.isInfixOf` Text
o)
                , Just Register
r <- [ Text -> Map Text Register -> Maybe Register
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Text
bare Text
o) Map Text Register
intelRegisters ] ]
    explicit :: [Register]
explicit = case [Text]
operands of
      (Text
o : [Text]
_) | Text -> Bool
writesOnly Text
m, Bool -> Bool
not (Text
"[" Text -> Text -> Bool
`T.isInfixOf` Text
o) -> Int -> [Register] -> [Register]
forall a. Int -> [a] -> [a]
drop Int
1 [Register]
named
      [Text]
_ -> [Register]
named
    sources :: [Register]
sources = [Register]
explicit [Register] -> [Register] -> [Register]
forall a. Semigroup a => a -> a -> a
<> [Register] -> Text -> Map Text [Register] -> [Register]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] Text
m Map Text [Register]
implicit

intelRows :: S.Set (T.Text, Word8)
intelRows :: Set (Text, Word8)
intelRows = [(Text, Word8)] -> Set (Text, Word8)
forall a. Ord a => [a] -> Set a
S.fromList [(Text, Word8)]
Intel.instructions

-- the mnemonic as Intel's list spells it: upper case, a condition by
-- its list name, a 64-bit immediate move as a move
mnemonic :: Line -> T.Text
mnemonic :: Line -> Text
mnemonic Line
l =
  let m :: Text
m = Text -> Text
T.toUpper (Line -> Text
lnMnemonic Line
l)
  in case Text
m of
       Text
"MOVABS" -> Text
"MOV"
       Text
_ -> case [ Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c' | Text
p <- [ Text
"CMOV", Text
"SET" ]
                           , Just Text
c <- [ Text -> Text -> Maybe Text
T.stripPrefix Text
p Text
m ]
                           , Just Text
c' <- [ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
c Map Text Text
conditions ] ] of
              (Text
n : [Text]
_) -> Text
n
              [] -> Text
m

conditions :: M.Map T.Text T.Text
conditions :: Map Text Text
conditions = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"O", Text
"O"), (Text
"NO", Text
"NO"), (Text
"B", Text
"B"), (Text
"C", Text
"B"), (Text
"NAE", Text
"B")
  , (Text
"NB", Text
"NB"), (Text
"AE", Text
"NB"), (Text
"NC", Text
"NB"), (Text
"Z", Text
"Z"), (Text
"E", Text
"Z")
  , (Text
"NZ", Text
"NZ"), (Text
"NE", Text
"NZ"), (Text
"BE", Text
"BE"), (Text
"NA", Text
"BE")
  , (Text
"NBE", Text
"NBE"), (Text
"A", Text
"NBE"), (Text
"S", Text
"S"), (Text
"NS", Text
"NS"), (Text
"P", Text
"P")
  , (Text
"PE", Text
"P"), (Text
"NP", Text
"NP"), (Text
"PO", Text
"NP"), (Text
"L", Text
"L"), (Text
"NGE", Text
"L")
  , (Text
"NL", Text
"NL"), (Text
"GE", Text
"NL"), (Text
"LE", Text
"LE"), (Text
"NG", Text
"LE")
  , (Text
"NLE", Text
"NLE"), (Text
"G", Text
"NLE") ]

-- control flow, system, and instructions that read no data
control :: S.Set T.Text
control :: Set Text
control = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList
  [ Text
"CALL", Text
"RET", Text
"LOOP", Text
"LOOPE", Text
"LOOPNE", Text
"SYSCALL", Text
"SYSENTER"
  , Text
"INT", Text
"INT3", Text
"INTO", Text
"UD1", Text
"UD2", Text
"HLT", Text
"NOP", Text
"PAUSE"
  , Text
"ENDBR32", Text
"ENDBR64", Text
"LFENCE", Text
"MFENCE", Text
"SFENCE", Text
"CPUID"
  , Text
"RDTSC", Text
"RDTSCP", Text
"XGETBV", Text
"RDRAND", Text
"RDSEED", Text
"ENTER", Text
"LEAVE"
  , Text
"PREFETCHT0", Text
"PREFETCHT1", Text
"PREFETCHT2", Text
"PREFETCHNTA"
  , Text
"PREFETCHW", Text
"CLFLUSH", Text
"CLFLUSHOPT" ]

-- instructions that write their first operand without reading it
writesOnly :: T.Text -> Bool
writesOnly :: Text -> Bool
writesOnly Text
m =
  (Text
"V" Text -> Text -> Bool
`T.isPrefixOf` Text
m Bool -> Bool -> Bool
&& Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"VZEROUPPER" Bool -> Bool -> Bool
&& Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"VZEROALL")
    Bool -> Bool -> Bool
|| Text
"MOV" Text -> Text -> Bool
`T.isPrefixOf` Text
m
    Bool -> Bool -> Bool
|| Text
"CVT" Text -> Text -> Bool
`T.isPrefixOf` Text
m
    Bool -> Bool -> Bool
|| (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
m) [ Text
"SQRT", Text
"RSQRT", Text
"RCP" ]
    Bool -> Bool -> Bool
|| Text
m Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Text
"POPCNT", Text
"LZCNT", Text
"TZCNT", Text
"PDEP", Text
"PEXT", Text
"BZHI"
                , Text
"BEXTR", Text
"BLSI", Text
"BLSR", Text
"BLSMSK", Text
"SARX", Text
"LEA" ]

-- registers read without being named
implicit :: M.Map T.Text [Register]
implicit :: Map Text [Register]
implicit = [(Text, [Register])] -> Map Text [Register]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"CBW", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
8 ]), (Text
"CWDE", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
16 ])
  , (Text
"CDQE", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
32 ]), (Text
"CWD", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
16 ])
  , (Text
"CDQ", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
32 ]), (Text
"CQO", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
64 ])
  , (Text
"SAHF", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
8 Int
8 ])
  , (Text
"CMPXCHG", [ Text -> Int -> Int -> Register
Register Text
"rax" Int
0 Int
64 ])
  , (Text
"CMPXCHG8B", (Text -> Register) -> [Text] -> [Register]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
r -> Text -> Int -> Int -> Register
Register Text
r Int
0 Int
32)
      [ Text
"rax", Text
"rdx", Text
"rbx", Text
"rcx" ])
  , (Text
"CMPXCHG16B", (Text -> Register) -> [Text] -> [Register]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
r -> Text -> Int -> Int -> Register
Register Text
r Int
0 Int
64)
      [ Text
"rax", Text
"rdx", Text
"rbx", Text
"rcx" ]) ]

-- an operand less its masking and broadcast decorations
bare :: T.Text -> T.Text
bare :: Text -> Text
bare = Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{')

-- operands, split at the commas between them
splitOperands :: T.Text -> [T.Text]
splitOperands :: Text -> [Text]
splitOperands Text
t
  | Text -> Bool
T.null (Text -> Text
T.strip Text
t) = []
  | Bool
otherwise = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip (Int -> String -> String -> [Text]
go Int
0 String
"" (Text -> String
T.unpack Text
t))
  where
    go :: Int -> String -> String -> [T.Text]
    go :: Int -> String -> String -> [Text]
go Int
_ String
acc [] = [ String -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse String
acc) ]
    go Int
d String
acc (Char
ch : String
rest) = case Char
ch of
      Char
'[' -> Int -> String -> String -> [Text]
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
rest
      Char
']' -> Int -> String -> String -> [Text]
go (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
rest
      Char
',' | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> String -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse String
acc) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> String -> String -> [Text]
go Int
d String
"" String
rest
      Char
_ -> Int -> String -> String -> [Text]
go Int
d (Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
rest

-- the general and vector registers QEMU exposes, by their names in
-- Intel syntax: a wide vector by its low 128 bits, which is all of
-- it QEMU names
intelRegisters :: M.Map T.Text Register
intelRegisters :: Map Text Register
intelRegisters = [(Text, Register)] -> Map Text Register
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Register)] -> Map Text Register)
-> [(Text, Register)] -> Map Text Register
forall a b. (a -> b) -> a -> b
$
  [[(Text, Register)]] -> [(Text, Register)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ (Text
r64, Text -> Int -> Int -> Register
Register Text
r64 Int
0 Int
64), (Text
r32, Text -> Int -> Int -> Register
Register Text
r64 Int
0 Int
32)
      , (Text
r16, Text -> Int -> Int -> Register
Register Text
r64 Int
0 Int
16), (Text
r8, Text -> Int -> Int -> Register
Register Text
r64 Int
0 Int
8) ]
    | (Text
r64, Text
r32, Text
r16, Text
r8) <-
        [ (Text
"rax", Text
"eax", Text
"ax", Text
"al"), (Text
"rbx", Text
"ebx", Text
"bx", Text
"bl")
        , (Text
"rcx", Text
"ecx", Text
"cx", Text
"cl"), (Text
"rdx", Text
"edx", Text
"dx", Text
"dl")
        , (Text
"rsi", Text
"esi", Text
"si", Text
"sil"), (Text
"rdi", Text
"edi", Text
"di", Text
"dil")
        , (Text
"rbp", Text
"ebp", Text
"bp", Text
"bpl"), (Text
"rsp", Text
"esp", Text
"sp", Text
"spl") ]
        [(Text, Text, Text, Text)]
-> [(Text, Text, Text, Text)] -> [(Text, Text, Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
n, Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"d", Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"w", Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"b")
           | Int
k <- [ Int
8 .. Int
15 :: Int ], let n :: Text
n = Text
"r" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
k) ] ]
  [(Text, Register)] -> [(Text, Register)] -> [(Text, Register)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
h, Text -> Int -> Int -> Register
Register Text
r Int
8 Int
8)
     | (Text
h, Text
r) <- [ (Text
"ah", Text
"rax"), (Text
"bh", Text
"rbx"), (Text
"ch", Text
"rcx")
                 , (Text
"dh", Text
"rdx") ] ]
  [(Text, Register)] -> [(Text, Register)] -> [(Text, Register)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
k), Text -> Int -> Int -> Register
Register (Text
"xmm" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
k)) Int
0 Int
128)
     | Text
p <- [ Text
"xmm", Text
"ymm", Text
"zmm" ], Int
k <- [ Int
0 .. Int
15 :: Int ] ]

-- the last opcode byte, past the prefixes, a REX, any VEX or EVEX
-- payload, and the escape bytes
opcode :: [Integer] -> Maybe Word8
opcode :: [Integer] -> Maybe Word8
opcode [Integer]
bs = (Integer -> Word8) -> Maybe Integer -> Maybe Word8
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Word8
forall a. Num a => Integer -> a
fromInteger ([Integer] -> Maybe Integer
forall {a}. (Ord a, Num a) => [a] -> Maybe a
go ((Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Integer -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
legacy [Integer]
bs))
  where
    legacy :: a -> Bool
legacy a
b = a
b a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ a
0x66, a
0x67, a
0xf0, a
0xf2, a
0xf3, a
0x2e, a
0x36
                        , a
0x3e, a
0x26, a
0x64, a
0x65 ]
    go :: [a] -> Maybe a
go [a]
xs = case [a]
xs of
      (a
b : [a]
rest) | a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0x40 Bool -> Bool -> Bool
&& a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x4f -> [a] -> Maybe a
forall {a}. (Eq a, Num a) => [a] -> Maybe a
escaped [a]
rest
      (a
0xd5 : a
_ : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
0 [a]
rest
      [a]
_ -> [a] -> Maybe a
forall {a}. (Eq a, Num a) => [a] -> Maybe a
escaped [a]
xs
    escaped :: [a] -> Maybe a
escaped [a]
xs = case [a]
xs of
      (a
0xc5 : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
1 [a]
rest
      (a
0xc4 : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
2 [a]
rest
      (a
0x62 : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
3 [a]
rest
      (a
0x0f : a
0x38 : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
0 [a]
rest
      (a
0x0f : a
0x3a : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
0 [a]
rest
      (a
0x0f : [a]
rest) -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
0 [a]
rest
      [a]
_ -> Int -> [a] -> Maybe a
forall {a}. Int -> [a] -> Maybe a
at Int
0 [a]
xs
    at :: Int -> [a] -> Maybe a
at Int
k [a]
xs = case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
k [a]
xs of
      (a
b : [a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
b
      [] -> Maybe a
forall a. Maybe a
Nothing

-- the watch list ----------------------------------------------------

-- | The plugin's watch list for one object, at its path: an @O@ line
--   naming it, then a @D@ line per division and a @U@ line per
--   instruction outside the contract, each with its address and its
--   text (a @U@ line with whether it names memory and the registers
--   it reads, each as name:low:width, before the text).
watchSection :: Contract -> FilePath -> [Line] -> T.Text
watchSection :: Contract -> String -> [Line] -> Text
watchSection Contract
c String
path [Line]
ls = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
  (Text
"O " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path)
  Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Line -> [Text]) -> [Line] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Line -> [Text]
entry [Line]
ls
  where
    entry :: Line -> [Text]
entry Line
l = case Contract -> Line -> Verdict
classify Contract
c Line
l of
      Verdict
Division -> [ Text
"D " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall {a}. Integral a => a -> Text
hex (Line -> Integer
lnAddress Line
l) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Line -> Text
text Line
l ]
      Watched [Register]
rs Bool
memory ->
        [ [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            [ Text
"U", Integer -> Text
forall {a}. Integral a => a -> Text
hex (Line -> Integer
lnAddress Line
l), if Bool
memory then Text
"1" else Text
"0"
            , String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([Register] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Register]
rs)) ]
            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Register -> Text
rgName Register
r 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 (Register -> Int
rgLow Register
r)) 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 (Register -> Int
rgWidth Register
r)) | Register
r <- [Register]
rs ]
            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Line -> Text
text Line
l ] ]
      Verdict
_ -> []
    text :: Line -> Text
text Line
l = [Text] -> Text
T.unwords ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)
      (Line -> [Text]
lnPrefixes Line
l [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Line -> Text
lnMnemonic Line
l, Line -> Text
lnOperands Line
l ]))
    hex :: a -> Text
hex a
n = String -> Text
T.pack (a -> ShowS
forall a. Integral a => a -> ShowS
showHex a
n String
"")