module Wrench.Machine.Types (
    Trace (..),
    Machine (..),
    Mem (..),
    IoMem (..),
    mkIoMem,
    Cell (..),
    InitState (..),
    Inspectable (..),
    StateEnv (..),
    MemOf,
    Intervals (..),
    emptyIntervals,
    recordRange,
    renderIntervals,
    renderIntervalsHex,
    inIntervals,
    intervalsSize,
    intervalsToList,
    intervalsRange,
    intervalsIntersect,
    intervalsUnion,
    intervalsDifference,
    AccessLog (..),
    emptyAccessLog,
    AccessSet (..),
    emptyAccessSet,
    toAccessLog,
    Touched,
    emptyTouched,
    touch,
    touchedIntervals,
    AccessCount (..),
    emptyAccessCount,
    acTotal,
    acSince,
    IsWord,
    FromSign (..),
    RegisterId,
    ByteSize (..),
    ByteSizeT (..),
    WordParts (..),
    RW (..),
    bump,
    halted,
) where

import Data.Bits
import Data.Default (Default, def)
import Data.IntMap.Strict qualified as IM
import Data.Interval qualified as I
import Data.IntervalSet (IntervalSet)
import Data.IntervalSet qualified as IS
import Data.Text qualified as T
import Numeric (showHex)
import Prelude qualified
import Relude
import Relude.Extra (keys)
import System.Random (StdGen)
import Wrench.Report.View (Stat, View)

-- * State

type IsWord w =
    ( Bits w
    , FiniteBits w
    , ByteSize w
    , ByteSizeT w
    , Default w
    , Enum w
    , FromSign w
    , Num (Unsign w)
    , Hashable w
    , Num w
    , Ord (Unsign w)
    , Ord w
    , Read w
    , Show w
    , WordParts w
    , Integral w
    , FromSign w
    , Bounded w
    , Bounded (Unsign w)
    )

type RegisterId r = (Hashable r, Show r, Read r)

class (Bits (Unsign w), Bounded (Unsign w), Integral (Unsign w), Show (Unsign w)) => FromSign w where
    type Unsign w :: Type
    fromSign :: w -> Unsign w
    toSign :: Unsign w -> w

instance FromSign Int8 where
    type Unsign Int8 = Word8
    fromSign :: Int8 -> Unsign Int8
fromSign = Int8 -> Word8
Int8 -> Unsign Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    toSign :: Unsign Int8 -> Int8
toSign = Word8 -> Int8
Unsign Int8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromSign Int32 where
    type Unsign Int32 = Word32
    fromSign :: Int32 -> Unsign Int32
fromSign = Int32 -> Word32
Int32 -> Unsign Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    toSign :: Unsign Int32 -> Int32
toSign = Word32 -> Int32
Unsign Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

class WordParts w where
    wordSplit :: w -> [Word8]
    wordCombine :: [Word8] -> w
    byteToWord :: Word8 -> w

instance WordParts Int32 where
    wordSplit :: Int32 -> [Word8]
wordSplit Int32
w = [Word8
byte3, Word8
byte2, Word8
byte1, Word8
byte0]
        where
            byte0 :: Word8
byte0 = Int32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word8) -> Int32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Int32
w Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24) Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.&. Int32
0xFF -- Extract the highest byte
            byte1 :: Word8
byte1 = Int32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word8) -> Int32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Int32
w Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.&. Int32
0xFF -- Extract the second byte
            byte2 :: Word8
byte2 = Int32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word8) -> Int32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Int32
w Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.&. Int32
0xFF -- Extract the third byte
            byte3 :: Word8
byte3 = Int32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word8) -> Int32 -> Word8
forall a b. (a -> b) -> a -> b
$ Int32
w Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.&. Int32
0xFF

    wordCombine :: [Word8] -> Int32
wordCombine [Word8
byte3, Word8
byte2, Word8
byte1, Word8
byte0] =
        (Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byte0 Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
            Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byte1 Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
            Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byte2 Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
            Int32 -> Int32 -> Int32
forall a. Bits a => a -> a -> a
.|. Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byte3
    wordCombine [Word8]
_ = Text -> Int32
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"not applicable"

    byteToWord :: Word8 -> Int32
byteToWord = Word8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance WordParts Int8 where
    wordSplit :: Int8 -> [Word8]
wordSplit Int8
b = [Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Integer -> Word8) -> Integer -> Word8
forall a b. (a -> b) -> a -> b
$ Int8 -> Integer
forall a. Integral a => a -> Integer
toInteger Int8
b]
    wordCombine :: [Word8] -> Int8
wordCombine [Word8
b] = Integer -> Int8
forall a. Num a => Integer -> a
fromInteger (Integer -> Int8) -> Integer -> Int8
forall a b. (a -> b) -> a -> b
$ Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger Word8
b
    wordCombine [Word8]
_ = Text -> Int8
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"not applicable"
    byteToWord :: Word8 -> Int8
byteToWord = Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

class ByteSize t where
    byteSize :: t -> Int

instance ByteSize Word32 where
    byteSize :: Word32 -> Int
byteSize Word32
_ = Int
4

instance ByteSize Int8 where
    byteSize :: Int8 -> Int
byteSize Int8
_ = Int
1

instance ByteSize Int32 where
    byteSize :: Int32 -> Int
byteSize Int32
_ = Int
4

class ByteSizeT t where
    byteSizeT :: Int

instance (ByteSize t, Default t) => ByteSizeT t where
    byteSizeT :: Int
byteSizeT = t -> Int
forall t. ByteSize t => t -> Int
byteSize (t
forall a. Default a => a
def :: t)

type family MemOf st

class InitState st where
    initState :: Int -> MemOf st -> StdGen -> st

class Inspectable st where
    type WordOf st
    type IsaOf st

    programCounter :: st -> Int
    memoryDump :: st -> MemOf st
    ioStreams :: st -> IntMap ([WordOf st], [WordOf st])

    -- | The ISA's own report views: registers, flags, stacks, run-wide stats.
    views :: [View (StateEnv st)]

    -- | The ISA's run-wide stats, read from the final state; @{isa-specific}@
    --   lists them.
    isaStats :: [Stat (StateEnv st)]
    isaStats = []

    isHalted :: st -> Bool

-- | What an ISA view sees.
data StateEnv st = StateEnv
    { forall st. StateEnv st -> HashMap Text (WordOf st)
seLabels :: HashMap Text (WordOf st)
    , forall st. StateEnv st -> st
seState :: st
    -- ^ The state of the record being rendered.
    , forall st. StateEnv st -> st
seFinal :: st
    -- ^ The state the run ended in, for run-wide stats: an accumulator read
    --   from 'seState' would lag the run.
    }

class Machine st isa w | st -> isa w where
    instructionFetch :: State st (Either Text (Int, isa))
    instructionStep :: State st ()
    instructionStep = do
        (pc, instruction) <- (Text -> (Int, isa))
-> ((Int, isa) -> (Int, isa))
-> Either Text (Int, isa)
-> (Int, isa)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> (Int, isa)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> (Int, isa)) -> (Text -> Text) -> Text -> (Int, isa)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"internal error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (Int, isa) -> (Int, isa)
forall a. a -> a
id (Either Text (Int, isa) -> (Int, isa))
-> StateT st Identity (Either Text (Int, isa))
-> StateT st Identity (Int, isa)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT st Identity (Either Text (Int, isa))
forall st isa w.
Machine st isa w =>
StateT st Identity (Either Text (Int, isa))
instructionFetch
        instructionExecute pc instruction
    instructionExecute :: Int -> isa -> State st ()

halted :: Text
halted :: Text
halted = Text
"halted"

data Trace st isa
    = -- | A captured machine state after executing @tInstructionCount@ instructions.
      --   @tPrevInstruction@ is the instruction that was just executed to reach
      --   this state (@Nothing@ for the initial state before any execution).
      TState
        { forall st isa. Trace st isa -> Int
tInstructionCount :: !Int
        , forall st isa. Trace st isa -> Maybe isa
tPrevInstruction :: !(Maybe isa)
        , forall st isa. Trace st isa -> st
tState :: !st
        }
    | TError Text
    | TWarn Text
    deriving (Int -> Trace st isa -> ShowS
[Trace st isa] -> ShowS
Trace st isa -> String
(Int -> Trace st isa -> ShowS)
-> (Trace st isa -> String)
-> ([Trace st isa] -> ShowS)
-> Show (Trace st isa)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall st isa. (Show isa, Show st) => Int -> Trace st isa -> ShowS
forall st isa. (Show isa, Show st) => [Trace st isa] -> ShowS
forall st isa. (Show isa, Show st) => Trace st isa -> String
$cshowsPrec :: forall st isa. (Show isa, Show st) => Int -> Trace st isa -> ShowS
showsPrec :: Int -> Trace st isa -> ShowS
$cshow :: forall st isa. (Show isa, Show st) => Trace st isa -> String
show :: Trace st isa -> String
$cshowList :: forall st isa. (Show isa, Show st) => [Trace st isa] -> ShowS
showList :: [Trace st isa] -> ShowS
Show)

data Mem isa w = Mem
    { forall isa w. Mem isa w -> Int
memorySize :: !Int
    , forall isa w. Mem isa w -> IntMap (Cell isa w)
memoryData :: !(IntMap (Cell isa w))
    }
    deriving (Mem isa w -> Mem isa w -> Bool
(Mem isa w -> Mem isa w -> Bool)
-> (Mem isa w -> Mem isa w -> Bool) -> Eq (Mem isa w)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall isa w. Eq isa => Mem isa w -> Mem isa w -> Bool
$c== :: forall isa w. Eq isa => Mem isa w -> Mem isa w -> Bool
== :: Mem isa w -> Mem isa w -> Bool
$c/= :: forall isa w. Eq isa => Mem isa w -> Mem isa w -> Bool
/= :: Mem isa w -> Mem isa w -> Bool
Eq, Int -> Mem isa w -> ShowS
[Mem isa w] -> ShowS
Mem isa w -> String
(Int -> Mem isa w -> ShowS)
-> (Mem isa w -> String)
-> ([Mem isa w] -> ShowS)
-> Show (Mem isa w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall isa w. Show isa => Int -> Mem isa w -> ShowS
forall isa w. Show isa => [Mem isa w] -> ShowS
forall isa w. Show isa => Mem isa w -> String
$cshowsPrec :: forall isa w. Show isa => Int -> Mem isa w -> ShowS
showsPrec :: Int -> Mem isa w -> ShowS
$cshow :: forall isa w. Show isa => Mem isa w -> String
show :: Mem isa w -> String
$cshowList :: forall isa w. Show isa => [Mem isa w] -> ShowS
showList :: [Mem isa w] -> ShowS
Show)

data IoMem isa w = IoMem
    { forall isa w. IoMem isa w -> IntMap ([w], [w])
mIoStreams :: IntMap ([w], [w])
    , forall isa w. IoMem isa w -> Mem isa w
mIoCells :: Mem isa w
    , forall isa w. IoMem isa w -> [Int]
mIoKeys :: [Int]
    , forall isa w. IoMem isa w -> IntMap Int
mIoByteToWord :: IntMap Int
    , forall isa w. IoMem isa w -> AccessSet
mAccessSet :: !AccessSet
    -- ^ Tracks the addresses touched at runtime, surfaced via @mem:*@.
    , forall isa w. IoMem isa w -> AccessCount
mAccessCount :: !AccessCount
    -- ^ Accesses served, one per operation, never reset.
    , forall isa w. IoMem isa w -> isa -> Int
mInstrFetchReads :: isa -> Int
    -- ^ Reads a fetch of the instruction costs: one per started machine word
    --   by default.
    }

-- | Every field but the 'mInstrFetchReads' function.
instance (Show isa, Show w) => Show (IoMem isa w) where
    show :: IoMem isa w -> String
show IoMem{IntMap ([w], [w])
mIoStreams :: forall isa w. IoMem isa w -> IntMap ([w], [w])
mIoStreams :: IntMap ([w], [w])
mIoStreams, Mem isa w
mIoCells :: forall isa w. IoMem isa w -> Mem isa w
mIoCells :: Mem isa w
mIoCells, [Int]
mIoKeys :: forall isa w. IoMem isa w -> [Int]
mIoKeys :: [Int]
mIoKeys, IntMap Int
mIoByteToWord :: forall isa w. IoMem isa w -> IntMap Int
mIoByteToWord :: IntMap Int
mIoByteToWord, AccessSet
mAccessSet :: forall isa w. IoMem isa w -> AccessSet
mAccessSet :: AccessSet
mAccessSet, AccessCount
mAccessCount :: forall isa w. IoMem isa w -> AccessCount
mAccessCount :: AccessCount
mAccessCount} =
        String
"IoMem " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (IntMap ([w], [w]), Mem isa w, [Int], IntMap Int, AccessLog,
 AccessCount)
-> String
forall b a. (Show a, IsString b) => a -> b
show (IntMap ([w], [w])
mIoStreams, Mem isa w
mIoCells, [Int]
mIoKeys, IntMap Int
mIoByteToWord, AccessSet -> AccessLog
toAccessLog AccessSet
mAccessSet, AccessCount
mAccessCount)

mkIoMem :: forall w isa. (ByteSize isa, ByteSizeT w) => IntMap ([w], [w]) -> Mem isa w -> IoMem isa w
mkIoMem :: forall w isa.
(ByteSize isa, ByteSizeT w) =>
IntMap ([w], [w]) -> Mem isa w -> IoMem isa w
mkIoMem IntMap ([w], [w])
streams Mem isa w
cells =
    IoMem
        { mIoStreams :: IntMap ([w], [w])
mIoStreams = IntMap ([w], [w])
streams
        , mIoCells :: Mem isa w
mIoCells = Mem isa w
cells
        , mIoKeys :: [Int]
mIoKeys = IntMap ([w], [w]) -> [Int]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [a]
keys IntMap ([w], [w])
streams
        , mAccessSet :: AccessSet
mAccessSet = AccessSet
emptyAccessSet
        , mAccessCount :: AccessCount
mAccessCount = AccessCount
emptyAccessCount
        , mInstrFetchReads :: isa -> Int
mInstrFetchReads = \isa
instr -> (isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
instr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall t. ByteSizeT t => Int
byteSizeT @w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` forall t. ByteSizeT t => Int
byteSizeT @w
        , mIoByteToWord :: IntMap Int
mIoByteToWord =
            [Item (IntMap Int)] -> IntMap Int
forall l. IsList l => [Item l] -> l
fromList ([Item (IntMap Int)] -> IntMap Int)
-> [Item (IntMap Int)] -> IntMap Int
forall a b. (a -> b) -> a -> b
$ (Int -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
i -> (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,Int
i) [Int
i .. Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall t. ByteSizeT t => Int
byteSizeT @w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) (IntMap ([w], [w]) -> [Int]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [a]
keys IntMap ([w], [w])
streams)
        }

data Cell isa w
    = Instruction !isa
    | InstructionPart
    | Value !Word8
    deriving (Cell isa w -> Cell isa w -> Bool
(Cell isa w -> Cell isa w -> Bool)
-> (Cell isa w -> Cell isa w -> Bool) -> Eq (Cell isa w)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall isa w. Eq isa => Cell isa w -> Cell isa w -> Bool
$c== :: forall isa w. Eq isa => Cell isa w -> Cell isa w -> Bool
== :: Cell isa w -> Cell isa w -> Bool
$c/= :: forall isa w. Eq isa => Cell isa w -> Cell isa w -> Bool
/= :: Cell isa w -> Cell isa w -> Bool
Eq, Int -> Cell isa w -> ShowS
[Cell isa w] -> ShowS
Cell isa w -> String
(Int -> Cell isa w -> ShowS)
-> (Cell isa w -> String)
-> ([Cell isa w] -> ShowS)
-> Show (Cell isa w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall isa w. Show isa => Int -> Cell isa w -> ShowS
forall isa w. Show isa => [Cell isa w] -> ShowS
forall isa w. Show isa => Cell isa w -> String
$cshowsPrec :: forall isa w. Show isa => Int -> Cell isa w -> ShowS
showsPrec :: Int -> Cell isa w -> ShowS
$cshow :: forall isa w. Show isa => Cell isa w -> String
show :: Cell isa w -> String
$cshowList :: forall isa w. Show isa => [Cell isa w] -> ShowS
showList :: [Cell isa w] -> ShowS
Show)

-----------------------------------------------------------
-- Address-range accounting (mem:* stats)

-- | Sorted, non-overlapping integer address ranges with adjacency merging.
--   Backed by 'IntervalSet' 'Integer' from the @data-interval@ package.
--
--   We store each access as the half-open interval @[lo, hi+1)@ so that two
--   integer-adjacent accesses (one ending at N, the next starting at N+1)
--   share a boundary and get merged by 'IS.insert'. On render we convert
--   back to the inclusive @"lo..hi"@ form by subtracting 1 from the upper.
newtype Intervals = Intervals {Intervals -> IntervalSet Integer
unIntervals :: IntervalSet Integer}
    deriving (Intervals -> Intervals -> Bool
(Intervals -> Intervals -> Bool)
-> (Intervals -> Intervals -> Bool) -> Eq Intervals
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Intervals -> Intervals -> Bool
== :: Intervals -> Intervals -> Bool
$c/= :: Intervals -> Intervals -> Bool
/= :: Intervals -> Intervals -> Bool
Eq, Int -> Intervals -> ShowS
[Intervals] -> ShowS
Intervals -> String
(Int -> Intervals -> ShowS)
-> (Intervals -> String)
-> ([Intervals] -> ShowS)
-> Show Intervals
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Intervals -> ShowS
showsPrec :: Int -> Intervals -> ShowS
$cshow :: Intervals -> String
show :: Intervals -> String
$cshowList :: [Intervals] -> ShowS
showList :: [Intervals] -> ShowS
Show)

emptyIntervals :: Intervals
emptyIntervals :: Intervals
emptyIntervals = IntervalSet Integer -> Intervals
Intervals IntervalSet Integer
forall r. Ord r => IntervalSet r
IS.empty

-- | Record an access spanning @[addr .. addr+len-1]@. Length must be ≥ 1.
recordRange :: Int -> Int -> Intervals -> Intervals
recordRange :: Int -> Int -> Intervals -> Intervals
recordRange Int
addr Int
len (Intervals IntervalSet Integer
s) =
    let lo :: Extended Integer
lo = Integer -> Extended Integer
forall r. r -> Extended r
I.Finite (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
addr)
        hi :: Extended Integer
hi = Integer -> Extended Integer
forall r. r -> Extended r
I.Finite (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len))
     in IntervalSet Integer -> Intervals
Intervals (Interval Integer -> IntervalSet Integer -> IntervalSet Integer
forall r. Ord r => Interval r -> IntervalSet r -> IntervalSet r
IS.insert (Extended Integer
lo Extended Integer -> Extended Integer -> Interval Integer
forall r. Ord r => Extended r -> Extended r -> Interval r
I.<=..< Extended Integer
hi) IntervalSet Integer
s)

-- | Render intervals as @"lo1..hi1, lo2..hi2"@ (or @"-"@ when empty),
--   using the given per-address formatter for both bounds.
renderIntervalsWith :: (Integer -> Text) -> Intervals -> Text
renderIntervalsWith :: (Integer -> Text) -> Intervals -> Text
renderIntervalsWith Integer -> Text
fmt (Intervals IntervalSet Integer
s) =
    case IntervalSet Integer -> [Interval Integer]
forall r. Ord r => IntervalSet r -> [Interval r]
IS.toAscList IntervalSet Integer
s of
        [] -> Text
"-"
        [Interval Integer]
is -> Text -> [Text] -> Text
T.intercalate Text
", " ((Interval Integer -> Text) -> [Interval Integer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Interval Integer -> Text
renderInterval [Interval Integer]
is)
    where
        renderInterval :: Interval Integer -> Text
renderInterval Interval Integer
i =
            let lo :: Integer
lo = case Interval Integer -> Extended Integer
forall r. Interval r -> Extended r
I.lowerBound Interval Integer
i of I.Finite Integer
n -> Integer
n; Extended Integer
_ -> Text -> Integer
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Intervals: unexpected infinite lower bound"
                hi :: Integer
hi = case Interval Integer -> Extended Integer
forall r. Interval r -> Extended r
I.upperBound Interval Integer
i of I.Finite Integer
n -> Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1; Extended Integer
_ -> Text -> Integer
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Intervals: unexpected infinite upper bound"
             in Integer -> Text
fmt Integer
lo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
fmt Integer
hi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show (Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" B)"

-- | Decimal-formatted ranges.
renderIntervals :: Intervals -> Text
renderIntervals :: Intervals -> Text
renderIntervals = (Integer -> Text) -> Intervals -> Text
renderIntervalsWith Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show

renderIntervalsHex :: Intervals -> Text
renderIntervalsHex :: Intervals -> Text
renderIntervalsHex = (Integer -> Text) -> Intervals -> Text
renderIntervalsWith (\Integer
n -> Text
"0x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
T.justifyRight Int
2 Char
'0' (String -> Text
forall a. ToText a => a -> Text
toText (Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex Integer
n String
"")))

-- | Membership test: is @addr@ inside any interval?
inIntervals :: Int -> Intervals -> Bool
inIntervals :: Int -> Intervals -> Bool
inIntervals Int
addr (Intervals IntervalSet Integer
s) = Integer -> IntervalSet Integer -> Bool
forall r. Ord r => r -> IntervalSet r -> Bool
IS.member (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
addr) IntervalSet Integer
s

-- | Total number of bytes covered by all intervals.
intervalsSize :: Intervals -> Int
intervalsSize :: Intervals -> Int
intervalsSize (Intervals IntervalSet Integer
s) =
    Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$
        [Integer] -> Integer
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum
            [ Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
lo
            | Interval Integer
i <- IntervalSet Integer -> [Interval Integer]
forall r. Ord r => IntervalSet r -> [Interval r]
IS.toAscList IntervalSet Integer
s
            , I.Finite Integer
lo <- [Interval Integer -> Extended Integer
forall r. Interval r -> Extended r
I.lowerBound Interval Integer
i]
            , I.Finite Integer
hi <- [Interval Integer -> Extended Integer
forall r. Interval r -> Extended r
I.upperBound Interval Integer
i]
            ]

-- | Convert intervals back to a list of inclusive @(lo, hi)@ pairs in
--   ascending order.
intervalsToList :: Intervals -> [(Int, Int)]
intervalsToList :: Intervals -> [(Int, Int)]
intervalsToList (Intervals IntervalSet Integer
s) =
    [ (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
lo, Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1))
    | Interval Integer
i <- IntervalSet Integer -> [Interval Integer]
forall r. Ord r => IntervalSet r -> [Interval r]
IS.toAscList IntervalSet Integer
s
    , I.Finite Integer
lo <- [Interval Integer -> Extended Integer
forall r. Interval r -> Extended r
I.lowerBound Interval Integer
i]
    , I.Finite Integer
hi <- [Interval Integer -> Extended Integer
forall r. Interval r -> Extended r
I.upperBound Interval Integer
i]
    ]

-- | Build an 'Intervals' covering the inclusive range @[lo, hi]@.
intervalsRange :: Int -> Int -> Intervals
intervalsRange :: Int -> Int -> Intervals
intervalsRange Int
lo Int
hi
    | Int
hi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lo = Intervals
emptyIntervals
    | Bool
otherwise = Int -> Int -> Intervals -> Intervals
recordRange Int
lo (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Intervals
emptyIntervals

intervalsIntersect :: Intervals -> Intervals -> Intervals
intervalsIntersect :: Intervals -> Intervals -> Intervals
intervalsIntersect (Intervals IntervalSet Integer
a) (Intervals IntervalSet Integer
b) = IntervalSet Integer -> Intervals
Intervals (IntervalSet Integer -> IntervalSet Integer -> IntervalSet Integer
forall r. Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
IS.intersection IntervalSet Integer
a IntervalSet Integer
b)

intervalsUnion :: Intervals -> Intervals -> Intervals
intervalsUnion :: Intervals -> Intervals -> Intervals
intervalsUnion (Intervals IntervalSet Integer
a) (Intervals IntervalSet Integer
b) = IntervalSet Integer -> Intervals
Intervals (IntervalSet Integer -> IntervalSet Integer -> IntervalSet Integer
forall r. Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
IS.union IntervalSet Integer
a IntervalSet Integer
b)

intervalsDifference :: Intervals -> Intervals -> Intervals
intervalsDifference :: Intervals -> Intervals -> Intervals
intervalsDifference (Intervals IntervalSet Integer
a) (Intervals IntervalSet Integer
b) = IntervalSet Integer -> Intervals
Intervals (IntervalSet Integer -> IntervalSet Integer -> IntervalSet Integer
forall r. Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
IS.difference IntervalSet Integer
a IntervalSet Integer
b)

-- | Runtime access ranges accumulated by 'IoMem' while the program runs.
data AccessLog = AccessLog
    { AccessLog -> Intervals
alInstr :: !Intervals
    -- ^ Instruction-fetch addresses.
    , AccessLog -> Intervals
alData :: !Intervals
    -- ^ Data read/write addresses (merged — we don't distinguish direction).
    , AccessLog -> Intervals
alIo :: !Intervals
    -- ^ Memory-mapped IO addresses touched.
    }
    deriving (AccessLog -> AccessLog -> Bool
(AccessLog -> AccessLog -> Bool)
-> (AccessLog -> AccessLog -> Bool) -> Eq AccessLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AccessLog -> AccessLog -> Bool
== :: AccessLog -> AccessLog -> Bool
$c/= :: AccessLog -> AccessLog -> Bool
/= :: AccessLog -> AccessLog -> Bool
Eq, Int -> AccessLog -> ShowS
[AccessLog] -> ShowS
AccessLog -> String
(Int -> AccessLog -> ShowS)
-> (AccessLog -> String)
-> ([AccessLog] -> ShowS)
-> Show AccessLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessLog -> ShowS
showsPrec :: Int -> AccessLog -> ShowS
$cshow :: AccessLog -> String
show :: AccessLog -> String
$cshowList :: [AccessLog] -> ShowS
showList :: [AccessLog] -> ShowS
Show)

emptyAccessLog :: AccessLog
emptyAccessLog :: AccessLog
emptyAccessLog = AccessLog{alInstr :: Intervals
alInstr = Intervals
emptyIntervals, alData :: Intervals
alData = Intervals
emptyIntervals, alIo :: Intervals
alIo = Intervals
emptyIntervals}

-- | Addresses touched at runtime, cheap to extend on every access; turned
--   into 'Intervals' only when a report asks ('toAccessLog').
--   Disjoint, non-adjacent inclusive ranges, keyed by their low end.
newtype Touched = Touched (IntMap Int)
    deriving (Touched -> Touched -> Bool
(Touched -> Touched -> Bool)
-> (Touched -> Touched -> Bool) -> Eq Touched
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Touched -> Touched -> Bool
== :: Touched -> Touched -> Bool
$c/= :: Touched -> Touched -> Bool
/= :: Touched -> Touched -> Bool
Eq, Int -> Touched -> ShowS
[Touched] -> ShowS
Touched -> String
(Int -> Touched -> ShowS)
-> (Touched -> String) -> ([Touched] -> ShowS) -> Show Touched
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Touched -> ShowS
showsPrec :: Int -> Touched -> ShowS
$cshow :: Touched -> String
show :: Touched -> String
$cshowList :: [Touched] -> ShowS
showList :: [Touched] -> ShowS
Show)

-- | Record an access spanning @[addr .. addr+len-1]@. Length must be ≥ 1.
touch :: Int -> Int -> Touched -> Touched
touch :: Int -> Int -> Touched -> Touched
touch Int
addr Int
len t :: Touched
t@(Touched IntMap Int
m)
    | Just (Int
_, Int
hi) <- Int -> IntMap Int -> Maybe (Int, Int)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupLE Int
addr IntMap Int
m, Int
hi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end = Touched
t
    | Bool
otherwise = IntMap Int -> Touched
Touched (Int -> Int -> IntMap Int -> IntMap Int
absorb Int
lo0 Int
hi0 IntMap Int
m0)
    where
        end :: Int
end = Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        (Int
lo0, Int
hi0, IntMap Int
m0) = case Int -> IntMap Int -> Maybe (Int, Int)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupLE Int
addr IntMap Int
m of
            Just (Int
lo, Int
hi) | Int
hi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 -> (Int
lo, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
hi Int
end, Int -> IntMap Int -> IntMap Int
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
lo IntMap Int
m)
            Maybe (Int, Int)
_ -> (Int
addr, Int
end, IntMap Int
m)
        absorb :: Int -> Int -> IntMap Int -> IntMap Int
absorb Int
lo Int
hi IntMap Int
acc = case Int -> IntMap Int -> Maybe (Int, Int)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupGE Int
lo IntMap Int
acc of
            Just (Int
lo', Int
hi') | Int
lo' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -> Int -> Int -> IntMap Int -> IntMap Int
absorb Int
lo (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
hi Int
hi') (Int -> IntMap Int -> IntMap Int
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
lo' IntMap Int
acc)
            Maybe (Int, Int)
_ -> Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
lo Int
hi IntMap Int
acc

touchedRanges :: Touched -> [(Int, Int)]
touchedRanges :: Touched -> [(Int, Int)]
touchedRanges (Touched IntMap Int
m) = IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IM.toAscList IntMap Int
m

emptyTouched :: Touched
emptyTouched :: Touched
emptyTouched = IntMap Int -> Touched
Touched IntMap Int
forall a. Monoid a => a
mempty

touchedIntervals :: Touched -> Intervals
touchedIntervals :: Touched -> Intervals
touchedIntervals Touched
t =
    IntervalSet Integer -> Intervals
Intervals (IntervalSet Integer -> Intervals)
-> IntervalSet Integer -> Intervals
forall a b. (a -> b) -> a -> b
$ [Interval Integer] -> IntervalSet Integer
forall r. Ord r => [Interval r] -> IntervalSet r
IS.fromList [Integer -> Extended Integer
forall r. r -> Extended r
I.Finite (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
lo) Extended Integer -> Extended Integer -> Interval Integer
forall r. Ord r => Extended r -> Extended r -> Interval r
I.<=..< Integer -> Extended Integer
forall r. r -> Extended r
I.Finite (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) | (Int
lo, Int
hi) <- Touched -> [(Int, Int)]
touchedRanges Touched
t]

-- | The raw form of 'AccessLog' that 'IoMem' keeps while the program runs.
data AccessSet = AccessSet
    { AccessSet -> Touched
asInstr :: !Touched
    , AccessSet -> Touched
asData :: !Touched
    , AccessSet -> Touched
asIo :: !Touched
    }
    deriving (AccessSet -> AccessSet -> Bool
(AccessSet -> AccessSet -> Bool)
-> (AccessSet -> AccessSet -> Bool) -> Eq AccessSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AccessSet -> AccessSet -> Bool
== :: AccessSet -> AccessSet -> Bool
$c/= :: AccessSet -> AccessSet -> Bool
/= :: AccessSet -> AccessSet -> Bool
Eq, Int -> AccessSet -> ShowS
[AccessSet] -> ShowS
AccessSet -> String
(Int -> AccessSet -> ShowS)
-> (AccessSet -> String)
-> ([AccessSet] -> ShowS)
-> Show AccessSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessSet -> ShowS
showsPrec :: Int -> AccessSet -> ShowS
$cshow :: AccessSet -> String
show :: AccessSet -> String
$cshowList :: [AccessSet] -> ShowS
showList :: [AccessSet] -> ShowS
Show)

emptyAccessSet :: AccessSet
emptyAccessSet :: AccessSet
emptyAccessSet = AccessSet{asInstr :: Touched
asInstr = Touched
emptyTouched, asData :: Touched
asData = Touched
emptyTouched, asIo :: Touched
asIo = Touched
emptyTouched}

toAccessLog :: AccessSet -> AccessLog
toAccessLog :: AccessSet -> AccessLog
toAccessLog AccessSet{Touched
asInstr :: AccessSet -> Touched
asInstr :: Touched
asInstr, Touched
asData :: AccessSet -> Touched
asData :: Touched
asData, Touched
asIo :: AccessSet -> Touched
asIo :: Touched
asIo} =
    AccessLog
        { alInstr :: Intervals
alInstr = Touched -> Intervals
touchedIntervals Touched
asInstr
        , alData :: Intervals
alData = Touched -> Intervals
touchedIntervals Touched
asData
        , alIo :: Intervals
alIo = Touched -> Intervals
touchedIntervals Touched
asIo
        }

-- | Reads and writes served, counted once per operation.
data AccessCount = AccessCount
    { AccessCount -> Int
acReads :: !Int
    , AccessCount -> Int
acWrites :: !Int
    }
    deriving (AccessCount -> AccessCount -> Bool
(AccessCount -> AccessCount -> Bool)
-> (AccessCount -> AccessCount -> Bool) -> Eq AccessCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AccessCount -> AccessCount -> Bool
== :: AccessCount -> AccessCount -> Bool
$c/= :: AccessCount -> AccessCount -> Bool
/= :: AccessCount -> AccessCount -> Bool
Eq, Int -> AccessCount -> ShowS
[AccessCount] -> ShowS
AccessCount -> String
(Int -> AccessCount -> ShowS)
-> (AccessCount -> String)
-> ([AccessCount] -> ShowS)
-> Show AccessCount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessCount -> ShowS
showsPrec :: Int -> AccessCount -> ShowS
$cshow :: AccessCount -> String
show :: AccessCount -> String
$cshowList :: [AccessCount] -> ShowS
showList :: [AccessCount] -> ShowS
Show)

-- | Which way an access went.
data RW = R | W

bump :: RW -> AccessCount -> AccessCount
bump :: RW -> AccessCount -> AccessCount
bump RW
R AccessCount
c = AccessCount
c{acReads = acReads c + 1}
bump RW
W AccessCount
c = AccessCount
c{acWrites = acWrites c + 1}

emptyAccessCount :: AccessCount
emptyAccessCount :: AccessCount
emptyAccessCount = AccessCount{acReads :: Int
acReads = Int
0, acWrites :: Int
acWrites = Int
0}

-- | Reads plus writes.
acTotal :: AccessCount -> Int
acTotal :: AccessCount -> Int
acTotal AccessCount{Int
acReads :: AccessCount -> Int
acReads :: Int
acReads, Int
acWrites :: AccessCount -> Int
acWrites :: Int
acWrites} = Int
acReads Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
acWrites

-- | What happened between two counts.
acSince :: AccessCount -> AccessCount -> AccessCount
acSince :: AccessCount -> AccessCount -> AccessCount
acSince AccessCount
before AccessCount
after =
    AccessCount
        { acReads :: Int
acReads = AccessCount -> Int
acReads AccessCount
after Int -> Int -> Int
forall a. Num a => a -> a -> a
- AccessCount -> Int
acReads AccessCount
before
        , acWrites :: Int
acWrites = AccessCount -> Int
acWrites AccessCount
after Int -> Int -> Int
forall a. Num a => a -> a -> a
- AccessCount -> Int
acWrites AccessCount
before
        }