{-# OPTIONS_GHC -Wno-missing-signatures #-}

module Wrench.Machine.Memory (
    sliceMem,
    Mem (..),
    Cell (..),
    Memory (..),
    readInstructions,
    WordParts (..),
    word32ToHex,
    hexAddr,
    hexAddrWidth,
    prepareDump,
    prettyDump,
    DumpStats (..),
    computeDumpStats,
) where

import Data.Bits (FiniteBits, finiteBitSize)
import Data.Default (Default, def)
import Data.Text qualified as T
import Numeric (showHex)
import Relude
import Relude.Extra
import Relude.Unsafe qualified as Unsafe
import Wrench.Machine.Types
import Wrench.Translator.Types

-- | Translation-time memory layout statistics, surfaced to report views via the
--   @layout:*@ namespace.
data DumpStats = DumpStats
    { DumpStats -> Int
dsSectionsTotalBytes :: !Int
    -- ^ Sum of byte sizes of all sections (no .org gaps).
    , DumpStats -> Int
dsTextSectionsBytes :: !Int
    -- ^ Sum of byte sizes of code (text) sections only.
    , DumpStats -> Int
dsDataSectionsBytes :: !Int
    -- ^ Sum of byte sizes of data sections only.
    , DumpStats -> Intervals
dsTextIntervals :: !Intervals
    -- ^ Address ranges of all code (text) sections.
    , DumpStats -> Intervals
dsDataIntervals :: !Intervals
    -- ^ Address ranges of all data sections.
    }
    deriving (DumpStats -> DumpStats -> Bool
(DumpStats -> DumpStats -> Bool)
-> (DumpStats -> DumpStats -> Bool) -> Eq DumpStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DumpStats -> DumpStats -> Bool
== :: DumpStats -> DumpStats -> Bool
$c/= :: DumpStats -> DumpStats -> Bool
/= :: DumpStats -> DumpStats -> Bool
Eq, Int -> DumpStats -> ShowS
[DumpStats] -> ShowS
DumpStats -> [Char]
(Int -> DumpStats -> ShowS)
-> (DumpStats -> [Char])
-> ([DumpStats] -> ShowS)
-> Show DumpStats
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DumpStats -> ShowS
showsPrec :: Int -> DumpStats -> ShowS
$cshow :: DumpStats -> [Char]
show :: DumpStats -> [Char]
$cshowList :: [DumpStats] -> ShowS
showList :: [DumpStats] -> ShowS
Show)

prepareDump ::
    (ByteSize isa, IsWord w) =>
    Int
    -> [Word8]
    -> [Section isa w w]
    -> Either Text (Mem isa w)
prepareDump :: forall isa w.
(ByteSize isa, IsWord w) =>
Int -> [Word8] -> [Section isa w w] -> Either Text (Mem isa w)
prepareDump Int
memorySize [Word8]
fillBytes [Section isa w w]
sections = do
    (_, sectionCells, _) <- ((Int, [(Int, Cell isa w)], Intervals)
 -> Section isa w w
 -> Either Text (Int, [(Int, Cell isa w)], Intervals))
-> (Int, [(Int, Cell isa w)], Intervals)
-> [Section isa w w]
-> Either Text (Int, [(Int, Cell isa w)], Intervals)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Int, [(Int, Cell isa w)], Intervals)
-> Section isa w w
-> Either Text (Int, [(Int, Cell isa w)], Intervals)
place (Int
0, [], Intervals
emptyIntervals) [Section isa w w]
sections
    let maxAddress = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (f :: * -> *) a. (Foldable1 f, Ord a) => f a -> a
maximum1 (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [(Int, Cell isa w)] -> [Int]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [a]
keys [(Int, Cell isa w)]
sectionCells
        placeholder = [Int] -> [Cell isa w] -> [(Int, Cell isa w)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 .. Int
memorySize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Word8 -> Cell isa w) -> [Word8] -> [Cell isa w]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Cell isa w
forall isa w. Word8 -> Cell isa w
Value [Word8]
fillBytes)
    if maxAddress > memorySize
        then
            Left $
                "program does not fit in memory: it needs "
                    <> show maxAddress
                    <> " bytes, but memory_size is "
                    <> show memorySize
                    <> " bytes. Increase memory_size in the configuration."
        else
            Right
                Mem
                    { memorySize
                    , memoryData = fromList (placeholder <> sectionCells)
                    }
    where
        place :: (Int, [(Int, Cell isa w)], Intervals)
-> Section isa w w
-> Either Text (Int, [(Int, Cell isa w)], Intervals)
place (Int
offset, [(Int, Cell isa w)]
dump, Intervals
used) Section isa w w
section =
            let start :: Int
start = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
offset (Section isa w w -> Maybe Int
forall isa w l. Section isa w l -> Maybe Int
org Section isa w w
section)
                cells :: [Cell isa w]
cells = case Section isa w w
section of
                    Code{[CodeToken isa w]
codeTokens :: [CodeToken isa w]
codeTokens :: forall isa w l. Section isa w l -> [CodeToken isa l]
codeTokens} -> [CodeToken isa w] -> [Cell isa w]
forall {l} {w}. [CodeToken isa l] -> [Cell isa w]
codeCells [CodeToken isa w]
codeTokens
                    Data{[DataToken w w]
dataTokens :: [DataToken w w]
dataTokens :: forall isa w l. Section isa w l -> [DataToken w l]
dataTokens} -> [DataToken w w] -> [Cell isa w]
forall {l} {isa} {w}. [DataToken w l] -> [Cell isa w]
dataCells [DataToken w w]
dataTokens
                len :: Int
len = [Cell isa w] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cell isa w]
cells
                newRange :: Intervals
newRange =
                    if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                        then Int -> Int -> Intervals -> Intervals
recordRange Int
start Int
len Intervals
emptyIntervals
                        else Intervals
emptyIntervals
                overlap :: Intervals
overlap = Intervals -> Intervals -> Intervals
intervalsIntersect Intervals
newRange Intervals
used
             in if Intervals -> Int
intervalsSize Intervals
overlap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                    then
                        Text -> Either Text (Int, [(Int, Cell isa w)], Intervals)
forall a b. a -> Either a b
Left (Text -> Either Text (Int, [(Int, Cell isa w)], Intervals))
-> Text -> Either Text (Int, [(Int, Cell isa w)], Intervals)
forall a b. (a -> b) -> a -> b
$
                            Text
"sections overlap: "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Section isa w w -> Text
forall {isa} {w} {l}. Section isa w l -> Text
sectionKind Section isa w w
section
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" section at mem["
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Intervals -> Text
renderIntervalsHex Intervals
newRange
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] overlaps bytes already placed at mem["
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Intervals -> Text
renderIntervalsHex Intervals
overlap
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
                    else
                        let (Int
offset', [(Int, Cell isa w)]
dump') = [Cell isa w]
-> Int -> [(Int, Cell isa w)] -> (Int, [(Int, Cell isa w)])
forall {b}. [b] -> Int -> [(Int, b)] -> (Int, [(Int, b)])
addSection [Cell isa w]
cells Int
start [(Int, Cell isa w)]
dump
                         in (Int, [(Int, Cell isa w)], Intervals)
-> Either Text (Int, [(Int, Cell isa w)], Intervals)
forall a b. b -> Either a b
Right (Int
offset', [(Int, Cell isa w)]
dump', Intervals -> Intervals -> Intervals
intervalsUnion Intervals
newRange Intervals
used)

        codeCells :: [CodeToken isa l] -> [Cell isa w]
codeCells =
            (CodeToken isa l -> [Cell isa w])
-> [CodeToken isa l] -> [Cell isa w]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                ( \case
                    Mnemonic isa
m ->
                        isa -> Cell isa w
forall isa w. isa -> Cell isa w
Instruction isa
m Cell isa w -> [Cell isa w] -> [Cell isa w]
forall a. a -> [a] -> [a]
: Int -> Cell isa w -> [Cell isa w]
forall a. Int -> a -> [a]
replicate (isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Cell isa w
forall isa w. Cell isa w
InstructionPart
                    CodeToken isa l
_other -> []
                )

        dataCells :: [DataToken w l] -> [Cell isa w]
dataCells =
            (DataToken w l -> [Cell isa w]) -> [DataToken w l] -> [Cell isa w]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                ( \case
                    DataToken{DataValue w
dtValue :: DataValue w
dtValue :: forall w l. DataToken w l -> DataValue w
dtValue} ->
                        (Word8 -> Cell isa w) -> [Word8] -> [Cell isa w]
forall a b. (a -> b) -> [a] -> [b]
map
                            Word8 -> Cell isa w
forall isa w. Word8 -> Cell isa w
Value
                            ([Word8] -> [Cell isa w]) -> [Word8] -> [Cell isa w]
forall a b. (a -> b) -> a -> b
$ case DataValue w
dtValue of
                                DByte [Word8]
bs -> [Word8]
bs
                                DWord [w]
ws -> (w -> [Word8]) -> [w] -> [Word8]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap w -> [Word8]
forall w. WordParts w => w -> [Word8]
wordSplit [w]
ws
                )

        sectionKind :: Section isa w l -> Text
sectionKind Code{} = Text
"text" :: Text
        sectionKind Data{} = Text
"data"

        addSection :: [b] -> Int -> [(Int, b)] -> (Int, [(Int, b)])
addSection [b]
cells Int
offset [(Int, b)]
dump =
            let dump' :: [(Int, b)]
dump' = [Int] -> [b] -> [(Int, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
offset ..] [b]
cells
             in (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Int, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, b)]
dump', [(Int, b)]
dump' [(Int, b)] -> [(Int, b)] -> [(Int, b)]
forall a. Semigroup a => a -> a -> a
<> [(Int, b)]
dump)

-- | Translation-time layout summary derived from the section list.
computeDumpStats :: (ByteSize isa, ByteSizeT w) => [Section isa w l] -> DumpStats
computeDumpStats :: forall isa w l.
(ByteSize isa, ByteSizeT w) =>
[Section isa w l] -> DumpStats
computeDumpStats [Section isa w l]
sections =
    let textBytes :: Int
textBytes = [Int] -> Int
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum [Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s | s :: Section isa w l
s@Code{} <- [Section isa w l]
sections]
        dataBytes :: Int
dataBytes = [Int] -> Int
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum [Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s | s :: Section isa w l
s@Data{} <- [Section isa w l]
sections]
        sectionRanges :: [(Section isa w l, Int)]
sectionRanges = Int -> [Section isa w l] -> [(Section isa w l, Int)]
forall isa w l.
(ByteSize isa, ByteSizeT w) =>
Int -> [Section isa w l] -> [(Section isa w l, Int)]
walkSectionRanges Int
0 [Section isa w l]
sections
        textIntervals :: Intervals
textIntervals =
            ((Section isa w l, Int) -> Intervals -> Intervals)
-> Intervals -> [(Section isa w l, Int)] -> Intervals
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                (\(Section isa w l
s, Int
lo) Intervals
acc -> if Section isa w l -> Bool
forall isa w l. Section isa w l -> Bool
isText Section isa w l
s Bool -> Bool -> Bool
&& Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> Int -> Intervals -> Intervals
recordRange Int
lo (Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s) Intervals
acc else Intervals
acc)
                Intervals
emptyIntervals
                [(Section isa w l, Int)]
sectionRanges
        dataIntervals :: Intervals
dataIntervals =
            ((Section isa w l, Int) -> Intervals -> Intervals)
-> Intervals -> [(Section isa w l, Int)] -> Intervals
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                (\(Section isa w l
s, Int
lo) Intervals
acc -> if Section isa w l -> Bool
forall isa w l. Section isa w l -> Bool
isData Section isa w l
s Bool -> Bool -> Bool
&& Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> Int -> Intervals -> Intervals
recordRange Int
lo (Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s) Intervals
acc else Intervals
acc)
                Intervals
emptyIntervals
                [(Section isa w l, Int)]
sectionRanges
     in DumpStats
            { dsSectionsTotalBytes :: Int
dsSectionsTotalBytes = Int
textBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dataBytes
            , dsTextSectionsBytes :: Int
dsTextSectionsBytes = Int
textBytes
            , dsDataSectionsBytes :: Int
dsDataSectionsBytes = Int
dataBytes
            , dsTextIntervals :: Intervals
dsTextIntervals = Intervals
textIntervals
            , dsDataIntervals :: Intervals
dsDataIntervals = Intervals
dataIntervals
            }

isValue :: Cell isa w -> Bool
isValue Value{} = Bool
True
isValue Cell isa w
_ = Bool
False

isText, isData :: Section isa w l -> Bool
isText :: forall isa w l. Section isa w l -> Bool
isText Code{} = Bool
True
isText Section isa w l
_ = Bool
False
isData :: forall isa w l. Section isa w l -> Bool
isData Data{} = Bool
True
isData Section isa w l
_ = Bool
False

-- | Resolve each section's starting offset (respecting @.org@) and pair it
--   with the section itself, in source order.
walkSectionRanges :: (ByteSize isa, ByteSizeT w) => Int -> [Section isa w l] -> [(Section isa w l, Int)]
walkSectionRanges :: forall isa w l.
(ByteSize isa, ByteSizeT w) =>
Int -> [Section isa w l] -> [(Section isa w l, Int)]
walkSectionRanges Int
_ [] = []
walkSectionRanges Int
offset (Section isa w l
s : [Section isa w l]
rest) =
    let start :: Int
start = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
offset (Section isa w l -> Maybe Int
forall isa w l. Section isa w l -> Maybe Int
org Section isa w l
s)
     in (Section isa w l
s, Int
start) (Section isa w l, Int)
-> [(Section isa w l, Int)] -> [(Section isa w l, Int)]
forall a. a -> [a] -> [a]
: Int -> [Section isa w l] -> [(Section isa w l, Int)]
forall isa w l.
(ByteSize isa, ByteSizeT w) =>
Int -> [Section isa w l] -> [(Section isa w l, Int)]
walkSectionRanges (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Section isa w l -> Int
forall t. ByteSize t => t -> Int
byteSize Section isa w l
s) [Section isa w l]
rest

sliceMem :: [Int] -> IntMap (Cell isa w) -> [(Int, Cell isa w)]
sliceMem :: forall isa w. [Int] -> IntMap (Cell isa w) -> [(Int, Cell isa w)]
sliceMem [Int]
addrs IntMap (Cell isa w)
memoryData = (Int -> (Int, Cell isa w)) -> [Int] -> [(Int, Cell isa w)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Int, Cell isa w)
cellAt [Int]
addrs
    where
        cellAt :: Int -> (Int, Cell isa w)
cellAt Int
a = case IntMap (Cell isa w)
memoryData IntMap (Cell isa w)
-> Key (IntMap (Cell isa w)) -> Maybe (Val (IntMap (Cell isa w)))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap (Cell isa w))
a of
            Just Val (IntMap (Cell isa w))
cell -> (Int
a, Val (IntMap (Cell isa w))
Cell isa w
cell)
            Maybe (Val (IntMap (Cell isa w)))
Nothing -> Text -> (Int, Cell isa w)
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> (Int, Cell isa w)) -> Text -> (Int, Cell isa w)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: outside the configured memory"

prettyDump ::
    forall w isa.
    (ByteSize isa, IsWord w, Show isa) =>
    Bool
    -> (Int -> Text)
    -> HashMap Text w
    -> IntMap (Cell isa w)
    -> Text
prettyDump :: forall w isa.
(ByteSize isa, IsWord w, Show isa) =>
Bool
-> (Int -> Text) -> HashMap Text w -> IntMap (Cell isa w) -> Text
prettyDump Bool
showSize Int -> Text
showAddr HashMap Text w
labels IntMap (Cell isa w)
mem = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [(Int, Cell isa w)] -> [Text]
pretty ([(Int, Cell isa w)] -> [Text]) -> [(Int, Cell isa w)] -> [Text]
forall a b. (a -> b) -> a -> b
$ IntMap (Cell isa w) -> [(Int, Cell isa w)]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [(a, b)]
toPairs IntMap (Cell isa w)
mem
    where
        sizeSuffix :: Int -> Text
sizeSuffix Int
n = if Bool
showSize then Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" B)" else Text
""
        offset2label :: HashMap Int Text
        offset2label :: HashMap Int Text
offset2label = [Item (HashMap Int Text)] -> HashMap Int Text
forall l. IsList l => [Item l] -> l
fromList ([Item (HashMap Int Text)] -> HashMap Int Text)
-> [Item (HashMap Int Text)] -> HashMap Int Text
forall a b. (a -> b) -> a -> b
$ ((Text, w) -> Item (HashMap Int Text))
-> [(Text, w)] -> [Item (HashMap Int Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
a, w
b) -> (w -> Int
forall a. Enum a => a -> Int
fromEnum w
b, Text
a)) ([(Text, w)] -> [Item (HashMap Int Text)])
-> [(Text, w)] -> [Item (HashMap Int Text)]
forall a b. (a -> b) -> a -> b
$ HashMap Text w -> [(Text, w)]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [(a, b)]
toPairs HashMap Text w
labels
        instruction :: Int -> Int -> isa -> Text
instruction Int
offset Int
n isa
i =
            let place :: Text
place = Text
"mem[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
showAddr Int
offset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
showAddr (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
sizeSuffix Int
n
                label :: Text
label = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
" \t@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (HashMap Int Text
offset2label HashMap Int Text
-> Key (HashMap Int Text) -> Maybe (Val (HashMap Int Text))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (HashMap Int Text)
offset)
             in Text
place Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": \t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> isa -> Text
forall b a. (Show a, IsString b) => a -> b
show isa
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label
        pretty :: [(Int, Cell isa w)] -> [Text]
pretty [] = []
        pretty ((Int
offset, Instruction isa
i) : [(Int, Cell isa w)]
cs) =
            let n :: Int
n = isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
i
                cs' :: [(Int, Cell isa w)]
cs' = Int -> [(Int, Cell isa w)] -> [(Int, Cell isa w)]
forall a. Int -> [a] -> [a]
drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(Int, Cell isa w)]
cs
             in Int -> Int -> isa -> Text
instruction Int
offset Int
n isa
i Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [(Int, Cell isa w)] -> [Text]
pretty [(Int, Cell isa w)]
cs'
        pretty ((Int
offset, Cell isa w
InstructionPart) : [(Int, Cell isa w)]
cs) = (Int -> Text
showAddr Int
offset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": \tInstructionPart") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [(Int, Cell isa w)] -> [Text]
pretty [(Int, Cell isa w)]
cs
        pretty [(Int, Cell isa w)]
cs =
            let values :: [(Int, Word8)]
values = ((Int, Cell isa w) -> (Int, Word8))
-> [(Int, Cell isa w)] -> [(Int, Word8)]
forall a b. (a -> b) -> [a] -> [b]
map ((Cell isa w -> Word8) -> (Int, Cell isa w) -> (Int, Word8)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\case (Value Word8
v) -> Word8
v; Cell isa w
_ -> Text -> Word8
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"impossible")) ([(Int, Cell isa w)] -> [(Int, Word8)])
-> [(Int, Cell isa w)] -> [(Int, Word8)]
forall a b. (a -> b) -> a -> b
$ ((Int, Cell isa w) -> Bool)
-> [(Int, Cell isa w)] -> [(Int, Cell isa w)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Cell isa w -> Bool
forall {isa} {w}. Cell isa w -> Bool
isValue (Cell isa w -> Bool)
-> ((Int, Cell isa w) -> Cell isa w) -> (Int, Cell isa w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Cell isa w) -> Cell isa w
forall a b. (a, b) -> b
snd) [(Int, Cell isa w)]
cs
                cs' :: [(Int, Cell isa w)]
cs' = ((Int, Cell isa w) -> Bool)
-> [(Int, Cell isa w)] -> [(Int, Cell isa w)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Cell isa w -> Bool
forall {isa} {w}. Cell isa w -> Bool
isValue (Cell isa w -> Bool)
-> ((Int, Cell isa w) -> Cell isa w) -> (Int, Cell isa w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Cell isa w) -> Cell isa w
forall a b. (a, b) -> b
snd) [(Int, Cell isa w)]
cs
             in [(Int, Word8)] -> Text
prettyData [(Int, Word8)]
values Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [(Int, Cell isa w)] -> [Text]
pretty [(Int, Cell isa w)]
cs'
        prettyData :: [(Int, Word8)] -> Text
prettyData [(Int, Word8)]
values = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [((Int, Maybe Text), Word8)] -> [Text]
merge ([((Int, Maybe Text), Word8)] -> [Text])
-> [((Int, Maybe Text), Word8)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [(Int, Word8)] -> [((Int, Maybe Text), Word8)]
forall {b}. Maybe Text -> [(Int, b)] -> [((Int, Maybe Text), b)]
mark Maybe Text
forall a. Maybe a
Nothing [(Int, Word8)]
values
        mark :: Maybe Text -> [(Int, b)] -> [((Int, Maybe Text), b)]
mark Maybe Text
_label [] = []
        mark Maybe Text
label ((Int
a, b
value) : [(Int, b)]
values) =
            let label' :: Maybe Text
label' = ((HashMap Int Text
offset2label HashMap Int Text
-> Key (HashMap Int Text) -> Maybe (Val (HashMap Int Text))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (HashMap Int Text)
a) Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
label)
             in ((Int
a, Maybe Text
label'), b
value) ((Int, Maybe Text), b)
-> [((Int, Maybe Text), b)] -> [((Int, Maybe Text), b)]
forall a. a -> [a] -> [a]
: Maybe Text -> [(Int, b)] -> [((Int, Maybe Text), b)]
mark Maybe Text
label' [(Int, b)]
values
        merge :: [((Int, Maybe Text), Word8)] -> [Text]
merge [] = []
        merge values :: [((Int, Maybe Text), Word8)]
values@(((Int
a, Maybe Text
label), Word8
_value) : [((Int, Maybe Text), Word8)]
_restValues) =
            let curValues :: [((Int, Maybe Text), Word8)]
curValues = (((Int, Maybe Text), Word8) -> Bool)
-> [((Int, Maybe Text), Word8)] -> [((Int, Maybe Text), Word8)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
label) (Maybe Text -> Bool)
-> (((Int, Maybe Text), Word8) -> Maybe Text)
-> ((Int, Maybe Text), Word8)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd ((Int, Maybe Text) -> Maybe Text)
-> (((Int, Maybe Text), Word8) -> (Int, Maybe Text))
-> ((Int, Maybe Text), Word8)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Maybe Text), Word8) -> (Int, Maybe Text)
forall a b. (a, b) -> a
fst) [((Int, Maybe Text), Word8)]
values
                b :: Int
b = (Int, Maybe Text) -> Int
forall a b. (a, b) -> a
fst ((Int, Maybe Text) -> Int) -> (Int, Maybe Text) -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, Maybe Text), Word8) -> (Int, Maybe Text)
forall a b. (a, b) -> a
fst (((Int, Maybe Text), Word8) -> (Int, Maybe Text))
-> ((Int, Maybe Text), Word8) -> (Int, Maybe Text)
forall a b. (a -> b) -> a -> b
$ [((Int, Maybe Text), Word8)] -> ((Int, Maybe Text), Word8)
forall a. HasCallStack => [a] -> a
Unsafe.last [((Int, Maybe Text), Word8)]
curValues
                restValues :: [((Int, Maybe Text), Word8)]
restValues = (((Int, Maybe Text), Word8) -> Bool)
-> [((Int, Maybe Text), Word8)] -> [((Int, Maybe Text), Word8)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
label) (Maybe Text -> Bool)
-> (((Int, Maybe Text), Word8) -> Maybe Text)
-> ((Int, Maybe Text), Word8)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd ((Int, Maybe Text) -> Maybe Text)
-> (((Int, Maybe Text), Word8) -> (Int, Maybe Text))
-> ((Int, Maybe Text), Word8)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Maybe Text), Word8) -> (Int, Maybe Text)
forall a b. (a, b) -> a
fst) [((Int, Maybe Text), Word8)]
values
             in ( Text
"mem["
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
showAddr Int
a
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".."
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
showAddr Int
b
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
sizeSuffix ([((Int, Maybe Text), Word8)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Int, Maybe Text), Word8)]
curValues)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": \t"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [((Int, Maybe Text), Word8)] -> Text
forall {b} {a}. Integral b => [(a, b)] -> Text
hexValues [((Int, Maybe Text), Word8)]
curValues
                    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
l -> Text
"\t@\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"") Maybe Text
label
                )
                    Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [((Int, Maybe Text), Word8)] -> [Text]
merge [((Int, Maybe Text), Word8)]
restValues
        hexValues :: [(a, b)] -> Text
hexValues [(a, b)]
values | ((a, b) -> Bool) -> [(a, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
0) (b -> Bool) -> ((a, b) -> b) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
forall a b. (a, b) -> b
snd) [(a, b)]
values Bool -> Bool -> Bool
&& [(a, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
values Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
16 = Text
"( 00 )"
        hexValues [(a, b)]
values = [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((a, b) -> Text) -> [(a, b)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
forall a. ToText a => a -> Text
toText ([Char] -> Text) -> ((a, b) -> [Char]) -> (a, b) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [Char]
forall {a}. Integral a => a -> [Char]
word8ToHex (b -> [Char]) -> ((a, b) -> b) -> (a, b) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
forall a b. (a, b) -> b
snd) [(a, b)]
values

word8ToHex :: a -> [Char]
word8ToHex a
w =
    let hex :: [Char]
hex = a -> ShowS
forall a. Integral a => a -> ShowS
showHex a
w [Char]
""
     in if [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
hex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then [Char]
"0" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
hex else [Char]
hex

word32ToHex :: a -> [Char]
word32ToHex a
w =
    let hex :: [Char]
hex = Word32 -> ShowS
forall a. Integral a => a -> ShowS
showHex (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w :: Int32) :: Word32) [Char]
""
     in [Char]
"0x" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
hex) Char
'0' [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
hex

-- | How many hex digits an address into a memory of this capacity could
--   ever need, e.g. a 512-byte memory only ever needs 3 (up to 0x1ff).
hexAddrWidth :: Int -> Int
hexAddrWidth :: Int -> Int
hexAddrWidth Int
capacity = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> ShowS
forall a. Integral a => a -> ShowS
showHex (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
capacity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [Char]
""))

-- | Render a byte address padded to 'width' hex digits, e.g. @0x00ff@ (or
--   @-0x01@ for the negative indices an out-of-bounds check can still
--   produce).
hexAddr :: Int -> Int -> Text
hexAddr :: Int -> Int -> Text
hexAddr Int
width Int
idx =
    let hex :: [Char]
hex = Int -> ShowS
forall a. Integral a => a -> ShowS
showHex (Int -> Int
forall a. Num a => a -> a
abs Int
idx) [Char]
""
        padded :: [Char]
padded = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
hex)) Char
'0' [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
hex
     in [Char] -> Text
forall a. ToText a => a -> Text
toText (if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then [Char]
"-0x" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
padded else [Char]
"0x" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
padded)

errAddr :: Int -> Int -> Text
errAddr :: Int -> Int -> Text
errAddr Int
capacity = Int -> Int -> Text
hexAddr (Int -> Int
hexAddrWidth Int
capacity)

class Memory m isa w | m -> isa w where
    readInstruction :: m -> Int -> Either Text (m, isa)
    readWord :: m -> Int -> Either Text (m, w)
    readByte :: m -> Int -> Either Text (m, Word8)
    writeWord :: m -> Int -> w -> Either Text m
    writeByte :: m -> Int -> Word8 -> Either Text m
    dumpCells :: m -> IntMap (Cell isa w)

    -- | Total addressable bytes.
    memCapacity :: m -> Int

    -- | Configured memory-mapped IO port starts (each spans one machine word).
    --   Default empty for memories without IO.
    ioPorts :: m -> [Int]
    ioPorts m
_ = []

    -- | Runtime address ranges touched by reads/writes/instruction-fetches.
    --   Default for memories that don't track (e.g. bare 'Mem') is empty.
    accessLog :: m -> AccessLog
    accessLog m
_ = AccessLog
emptyAccessLog

    -- | How many read/write we perform.
    memAccessCount :: m -> AccessCount

instance
    (ByteSize isa, IsWord w) =>
    Memory (Mem isa w) isa w
    where
    readInstruction :: Mem isa w -> Int -> Either Text (Mem isa w, isa)
readInstruction mem :: Mem isa w
mem@Mem{IntMap (Cell isa w)
memoryData :: forall isa w. Mem isa w -> IntMap (Cell isa w)
memoryData :: IntMap (Cell isa w)
memoryData, Int
memorySize :: forall isa w. Mem isa w -> Int
memorySize :: Int
memorySize} Int
idx =
        case IntMap (Cell isa w)
memoryData IntMap (Cell isa w)
-> Key (IntMap (Cell isa w)) -> Maybe (Val (IntMap (Cell isa w)))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap (Cell isa w))
idx of
            Just (Instruction isa
i)
                | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
                    ( \Int
addr -> case IntMap (Cell isa w)
memoryData IntMap (Cell isa w)
-> Key (IntMap (Cell isa w)) -> Maybe (Val (IntMap (Cell isa w)))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap (Cell isa w))
addr of
                        Just Val (IntMap (Cell isa w))
Cell isa w
InstructionPart -> Bool
True
                        Maybe (Val (IntMap (Cell isa w)))
_ -> Bool
False
                    )
                    [Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ->
                    (Mem isa w, isa) -> Either Text (Mem isa w, isa)
forall a b. b -> Either a b
Right (Mem isa w
mem, isa
i)
                | Bool
otherwise -> Text -> Either Text (Mem isa w, isa)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, isa))
-> Text -> Either Text (Mem isa w, isa)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: instruction in memory corrupted"
            Just Val (IntMap (Cell isa w))
Cell isa w
InstructionPart -> Text -> Either Text (Mem isa w, isa)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, isa))
-> Text -> Either Text (Mem isa w, isa)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: instruction in memory corrupted"
            Just (Value Word8
_) -> Text -> Either Text (Mem isa w, isa)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, isa))
-> Text -> Either Text (Mem isa w, isa)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: can't read instruction from data cell"
            Maybe (Val (IntMap (Cell isa w)))
Nothing -> Text -> Either Text (Mem isa w, isa)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, isa))
-> Text -> Either Text (Mem isa w, isa)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: out of memory"

    readByte :: Mem isa w -> Int -> Either Text (Mem isa w, Word8)
readByte mem :: Mem isa w
mem@Mem{IntMap (Cell isa w)
memoryData :: forall isa w. Mem isa w -> IntMap (Cell isa w)
memoryData :: IntMap (Cell isa w)
memoryData, Int
memorySize :: forall isa w. Mem isa w -> Int
memorySize :: Int
memorySize} Int
idx =
        case IntMap (Cell isa w)
memoryData IntMap (Cell isa w)
-> Key (IntMap (Cell isa w)) -> Maybe (Val (IntMap (Cell isa w)))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap (Cell isa w))
idx of
            Just (Value Word8
v) -> (Mem isa w, Word8) -> Either Text (Mem isa w, Word8)
forall a b. b -> Either a b
Right (Mem isa w
mem, Word8
v)
            Just Val (IntMap (Cell isa w))
_ -> Text -> Either Text (Mem isa w, Word8)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, Word8))
-> Text -> Either Text (Mem isa w, Word8)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: can't read byte from instruction cell"
            Maybe (Val (IntMap (Cell isa w)))
Nothing -> Text -> Either Text (Mem isa w, Word8)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, Word8))
-> Text -> Either Text (Mem isa w, Word8)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: out of memory"

    readWord :: Mem isa w -> Int -> Either Text (Mem isa w, w)
readWord Mem isa w
mem Int
idx =
        let idxs :: [Int]
idxs = [Int
idx .. Int
idx 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]
            values :: [Either Text Word8]
values = (Int -> Either Text Word8) -> [Int] -> [Either Text Word8]
forall a b. (a -> b) -> [a] -> [b]
map (((Mem isa w, Word8) -> Word8)
-> Either Text (Mem isa w, Word8) -> Either Text Word8
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Mem isa w, Word8) -> Word8
forall a b. (a, b) -> b
snd (Either Text (Mem isa w, Word8) -> Either Text Word8)
-> (Int -> Either Text (Mem isa w, Word8))
-> Int
-> Either Text Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mem isa w -> Int -> Either Text (Mem isa w, Word8)
forall m isa w.
Memory m isa w =>
m -> Int -> Either Text (m, Word8)
readByte Mem isa w
mem) [Int]
idxs
         in case [Either Text Word8] -> [Text]
forall a b. [Either a b] -> [a]
lefts [Either Text Word8]
values of
                [] -> (Mem isa w, w) -> Either Text (Mem isa w, w)
forall a b. b -> Either a b
Right (Mem isa w
mem, [Word8] -> w
forall w. WordParts w => [Word8] -> w
wordCombine ([Word8] -> w) -> [Word8] -> w
forall a b. (a -> b) -> a -> b
$ [Either Text Word8] -> [Word8]
forall a b. [Either a b] -> [b]
rights [Either Text Word8]
values)
                [Text]
errs -> Text -> Either Text (Mem isa w, w)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w, w))
-> Text -> Either Text (Mem isa w, w)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines [Text]
errs

    writeWord :: Mem isa w -> Int -> w -> Either Text (Mem isa w)
writeWord Mem{Int
memorySize :: forall isa w. Mem isa w -> Int
memorySize :: Int
memorySize} Int
idx w
_
        | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
memorySize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall t. ByteSizeT t => Int
byteSizeT @w =
            Text -> Either Text (Mem isa w)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w))
-> Text -> Either Text (Mem isa w)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: out of memory for word access"
    writeWord Mem isa w
mem Int
idx w
word =
        let updates :: [(Int, Word8)]
updates = [Int] -> [Word8] -> [(Int, Word8)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
idx ..] (w -> [Word8]
forall w. WordParts w => w -> [Word8]
wordSplit w
word)
         in (Mem isa w -> (Int, Word8) -> Either Text (Mem isa w))
-> Mem isa w -> [(Int, Word8)] -> Either Text (Mem isa w)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\Mem isa w
m (Int
i, Word8
x) -> Mem isa w -> Int -> Word8 -> Either Text (Mem isa w)
forall m isa w.
Memory m isa w =>
m -> Int -> Word8 -> Either Text m
writeByte Mem isa w
m Int
i Word8
x) Mem isa w
mem [(Int, Word8)]
updates

    writeByte :: Mem isa w -> Int -> Word8 -> Either Text (Mem isa w)
writeByte Mem{Int
memorySize :: forall isa w. Mem isa w -> Int
memorySize :: Int
memorySize} Int
idx Word8
_
        | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
memorySize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
idx = Text -> Either Text (Mem isa w)
forall a b. a -> Either a b
Left (Text -> Either Text (Mem isa w))
-> Text -> Either Text (Mem isa w)
forall a b. (a -> b) -> a -> b
$ Text
"memory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr Int
memorySize Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: out of memory"
    writeByte mem :: Mem isa w
mem@Mem{IntMap (Cell isa w)
memoryData :: forall isa w. Mem isa w -> IntMap (Cell isa w)
memoryData :: IntMap (Cell isa w)
memoryData} Int
idx Word8
byte =
        let memoryData' :: IntMap (Cell isa w)
memoryData' = Key (IntMap (Cell isa w))
-> Val (IntMap (Cell isa w))
-> IntMap (Cell isa w)
-> IntMap (Cell isa w)
forall t. DynamicMap t => Key t -> Val t -> t -> t
insert Int
Key (IntMap (Cell isa w))
idx (Word8 -> Cell isa w
forall isa w. Word8 -> Cell isa w
Value Word8
byte) IntMap (Cell isa w)
memoryData
         in Mem isa w -> Either Text (Mem isa w)
forall a b. b -> Either a b
Right (Mem isa w -> Either Text (Mem isa w))
-> Mem isa w -> Either Text (Mem isa w)
forall a b. (a -> b) -> a -> b
$ Mem isa w
mem{memoryData = memoryData'}

    dumpCells :: Mem isa w -> IntMap (Cell isa w)
dumpCells Mem{IntMap (Cell isa w)
memoryData :: forall isa w. Mem isa w -> IntMap (Cell isa w)
memoryData :: IntMap (Cell isa w)
memoryData} = IntMap (Cell isa w)
memoryData

    memCapacity :: Mem isa w -> Int
memCapacity Mem{Int
memorySize :: forall isa w. Mem isa w -> Int
memorySize :: Int
memorySize} = Int
memorySize

    memAccessCount :: Mem isa w -> AccessCount
memAccessCount Mem isa w
_ = AccessCount
emptyAccessCount

ioPortInstructionCollision ::
    forall w isa. (ByteSize isa, Default w, FiniteBits w) => IoMem isa w -> Int -> isa -> Bool
ioPortInstructionCollision :: forall w isa.
(ByteSize isa, Default w, FiniteBits w) =>
IoMem isa w -> Int -> isa -> Bool
ioPortInstructionCollision IoMem{[Int]
mIoKeys :: [Int]
mIoKeys :: forall isa w. IoMem isa w -> [Int]
mIoKeys} Int
addr isa
instr =
    let !n :: Int
n = isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
instr
        wn :: Int
wn = w -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (w
forall a. Default a => a
def :: w) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
        !result :: Bool
result = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
idx -> (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
addr Bool -> Bool -> Bool
&& Int
addr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool -> Bool -> Bool
|| (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
addr Bool -> Bool -> Bool
&& Int
addr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [Int]
mIoKeys
     in Bool
result

ioPortWordCollision :: forall w isa. (Default w, FiniteBits w) => IoMem isa w -> Int -> Bool
ioPortWordCollision :: forall w isa.
(Default w, FiniteBits w) =>
IoMem isa w -> Int -> Bool
ioPortWordCollision IoMem{[Int]
mIoKeys :: forall isa w. IoMem isa w -> [Int]
mIoKeys :: [Int]
mIoKeys} Int
addr =
    let n :: Int
n = w -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (w
forall a. Default a => a
def :: w) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
     in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
idx -> (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
addr Bool -> Bool -> Bool
&& Int
addr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool -> Bool -> Bool
|| (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
addr Bool -> Bool -> Bool
&& Int
addr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [Int]
mIoKeys

ioPortByteCollision :: forall w isa. (Default w, FiniteBits w) => IoMem isa w -> Int -> Bool
ioPortByteCollision :: forall w isa.
(Default w, FiniteBits w) =>
IoMem isa w -> Int -> Bool
ioPortByteCollision IoMem{[Int]
mIoKeys :: forall isa w. IoMem isa w -> [Int]
mIoKeys :: [Int]
mIoKeys} Int
addr =
    let n :: Int
n = w -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (w
forall a. Default a => a
def :: w) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
        mkParts :: Int -> [Int]
mkParts Int
idx = [Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 .. Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        parts :: [Int]
parts = (Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Int]
mkParts [Int]
mIoKeys
     in (Int
addr Int -> [Int] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Int]
parts)

-- | Record one access. Every successful read and write goes through exactly
-- one of these, so a word access counts once rather than per byte. An
-- instruction fetch counts the reads it is given.
recordInstrAccess :: Int -> Int -> Int -> IoMem isa w -> IoMem isa w
recordInstrAccess :: forall isa w. Int -> Int -> Int -> IoMem isa w -> IoMem isa w
recordInstrAccess Int
addr Int
len Int
fetchReads io :: IoMem isa w
io@IoMem{AccessSet
mAccessSet :: AccessSet
mAccessSet :: forall isa w. IoMem isa w -> AccessSet
mAccessSet, AccessCount
mAccessCount :: AccessCount
mAccessCount :: forall isa w. IoMem isa w -> AccessCount
mAccessCount} =
    IoMem isa w
io
        { mAccessSet = mAccessSet{asInstr = touch addr len (asInstr mAccessSet)}
        , mAccessCount = mAccessCount{acReads = acReads mAccessCount + fetchReads}
        }

recordDataAccess :: RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordDataAccess :: forall isa w. RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordDataAccess RW
rw Int
addr Int
len io :: IoMem isa w
io@IoMem{AccessSet
mAccessSet :: forall isa w. IoMem isa w -> AccessSet
mAccessSet :: AccessSet
mAccessSet, AccessCount
mAccessCount :: forall isa w. IoMem isa w -> AccessCount
mAccessCount :: AccessCount
mAccessCount} =
    IoMem isa w
io
        { mAccessSet = mAccessSet{asData = touch addr len (asData mAccessSet)}
        , mAccessCount = bump rw mAccessCount
        }

recordIoAccess :: RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordIoAccess :: forall isa w. RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordIoAccess RW
rw Int
addr Int
len io :: IoMem isa w
io@IoMem{AccessSet
mAccessSet :: forall isa w. IoMem isa w -> AccessSet
mAccessSet :: AccessSet
mAccessSet, AccessCount
mAccessCount :: forall isa w. IoMem isa w -> AccessCount
mAccessCount :: AccessCount
mAccessCount} =
    IoMem isa w
io
        { mAccessSet = mAccessSet{asIo = touch addr len (asIo mAccessSet)}
        , mAccessCount = bump rw mAccessCount
        }

-- | The instruction at @idx@, without recording an access.
ioInstructionAt :: (ByteSize isa, IsWord w, Memory (Mem isa w) isa w) => IoMem isa w -> Int -> Either Text isa
ioInstructionAt :: forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w -> Int -> Either Text isa
ioInstructionAt io :: IoMem isa w
io@IoMem{IntMap ([w], [w])
mIoStreams :: IntMap ([w], [w])
mIoStreams :: forall isa w. IoMem isa w -> IntMap ([w], [w])
mIoStreams, Mem isa w
mIoCells :: Mem isa w
mIoCells :: forall isa w. IoMem isa w -> Mem isa w
mIoCells} Int
idx =
    case IntMap ([w], [w])
mIoStreams IntMap ([w], [w])
-> Key (IntMap ([w], [w])) -> Maybe (Val (IntMap ([w], [w])))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap ([w], [w]))
idx of
        Just Val (IntMap ([w], [w]))
_ -> Text -> Either Text isa
forall a b. a -> Either a b
Left (Text -> Either Text isa) -> Text -> Either Text isa
forall a b. (a -> b) -> a -> b
$ Text
"iomemory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr (IoMem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity IoMem isa w
io) Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: instruction in memory corrupted"
        Maybe (Val (IntMap ([w], [w])))
Nothing -> case Mem isa w -> Int -> Either Text (Mem isa w, isa)
forall m isa w. Memory m isa w => m -> Int -> Either Text (m, isa)
readInstruction Mem isa w
mIoCells Int
idx of
            Left Text
err -> Text -> Either Text isa
forall a b. a -> Either a b
Left Text
err
            Right (Mem isa w
_mIoCells', isa
instr)
                | IoMem isa w -> Int -> isa -> Bool
forall w isa.
(ByteSize isa, Default w, FiniteBits w) =>
IoMem isa w -> Int -> isa -> Bool
ioPortInstructionCollision IoMem isa w
io Int
idx isa
instr ->
                    Text -> Either Text isa
forall a b. a -> Either a b
Left (Text -> Either Text isa) -> Text -> Either Text isa
forall a b. (a -> b) -> a -> b
$ Text
"iomemory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr (IoMem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity IoMem isa w
io) Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: instruction in memory corrupted"
                | Bool
otherwise -> isa -> Either Text isa
forall a b. b -> Either a b
Right isa
instr

-- | Read the instruction at @idx@ a word at a time from @idx@ on, one read
-- per started word, and return it with every following instruction that
-- ends inside the first word read. An instruction longer than a word comes
-- alone.
readInstructions ::
    forall isa w.
    (ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
    IoMem isa w
    -> Int
    -> Either Text (IoMem isa w, NonEmpty (Int, isa))
readInstructions :: forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w
-> Int -> Either Text (IoMem isa w, NonEmpty (Int, isa))
readInstructions IoMem isa w
io Int
idx = do
    instr <- IoMem isa w -> Int -> Either Text isa
forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w -> Int -> Either Text isa
ioInstructionAt IoMem isa w
io Int
idx
    let wordsRead = (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
        end = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall t. ByteSizeT t => Int
byteSizeT @w
        following Int
addr = case IoMem isa w -> Int -> Either Text isa
forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w -> Int -> Either Text isa
ioInstructionAt IoMem isa w
io Int
addr of
            Right isa
i | Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
end -> (Int
addr, isa
i) (Int, isa) -> [(Int, isa)] -> [(Int, isa)]
forall a. a -> [a] -> [a]
: Int -> [(Int, isa)]
following (Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
i)
            Either Text isa
_ -> []
        rest = Int -> [(Int, isa)]
following (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
instr)
        io' = Int -> Int -> Int -> IoMem isa w -> IoMem isa w
forall isa w. Int -> Int -> Int -> IoMem isa w -> IoMem isa w
recordInstrAccess Int
idx (isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
instr) Int
wordsRead IoMem isa w
io
    return
        ( foldl' (\IoMem isa w
m (Int
addr, isa
i) -> Int -> Int -> Int -> IoMem isa w -> IoMem isa w
forall isa w. Int -> Int -> Int -> IoMem isa w -> IoMem isa w
recordInstrAccess Int
addr (isa -> Int
forall t. ByteSize t => t -> Int
byteSize isa
i) Int
0 IoMem isa w
m) io' rest
        , (idx, instr) :| rest
        )

instance (ByteSize isa, IsWord w, Memory (Mem isa w) isa w) => Memory (IoMem isa w) isa w where
    readInstruction :: IoMem isa w -> Int -> Either Text (IoMem isa w, isa)
readInstruction io :: IoMem isa w
io@IoMem{isa -> Int
mInstrFetchReads :: isa -> Int
mInstrFetchReads :: forall isa w. IoMem isa w -> isa -> Int
mInstrFetchReads} Int
idx = do
        instr <- IoMem isa w -> Int -> Either Text isa
forall isa w.
(ByteSize isa, IsWord w, Memory (Mem isa w) isa w) =>
IoMem isa w -> Int -> Either Text isa
ioInstructionAt IoMem isa w
io Int
idx
        return (recordInstrAccess idx (byteSize instr) (mInstrFetchReads instr) io, instr)

    readByte :: IoMem isa w -> Int -> Either Text (IoMem isa w, Word8)
readByte io :: IoMem isa w
io@IoMem{IntMap Int
mIoByteToWord :: IntMap Int
mIoByteToWord :: forall isa w. IoMem isa w -> IntMap Int
mIoByteToWord} Int
idx
        | Just Val (IntMap Int)
wordIdx <- IntMap Int
mIoByteToWord IntMap Int -> Key (IntMap Int) -> Maybe (Val (IntMap Int))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap Int)
idx = do
            (io', word) <- IoMem isa w -> Int -> Either Text (IoMem isa w, w)
forall m isa w. Memory m isa w => m -> Int -> Either Text (m, w)
readWord IoMem isa w
io Int
Val (IntMap Int)
wordIdx
            return (io', wordSplit word Unsafe.!! (idx - wordIdx))
    readByte io :: IoMem isa w
io@IoMem{Mem isa w
mIoCells :: forall isa w. IoMem isa w -> Mem isa w
mIoCells :: Mem isa w
mIoCells} Int
idx = do
        (mIoCells', v) <- Mem isa w -> Int -> Either Text (Mem isa w, Word8)
forall m isa w.
Memory m isa w =>
m -> Int -> Either Text (m, Word8)
readByte Mem isa w
mIoCells Int
idx
        return (recordDataAccess R idx 1 io{mIoCells = mIoCells'}, v)

    readWord :: IoMem isa w -> Int -> Either Text (IoMem isa w, w)
readWord IoMem isa w
io Int
idx
        | IoMem isa w -> Int -> Bool
forall w isa.
(Default w, FiniteBits w) =>
IoMem isa w -> Int -> Bool
ioPortWordCollision IoMem isa w
io Int
idx =
            Text -> Either Text (IoMem isa w, w)
forall a b. a -> Either a b
Left (Text -> Either Text (IoMem isa w, w))
-> Text -> Either Text (IoMem isa w, w)
forall a b. (a -> b) -> a -> b
$ Text
"iomemory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr (IoMem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity IoMem isa w
io) Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: can't read word from input port"
    readWord io :: IoMem isa w
io@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
idx = do
        case IntMap ([w], [w])
mIoStreams IntMap ([w], [w])
-> Key (IntMap ([w], [w])) -> Maybe (Val (IntMap ([w], [w])))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap ([w], [w]))
idx of
            Just ([], [w]
_) -> Text -> Either Text (IoMem isa w, w)
forall a b. a -> Either a b
Left (Text -> Either Text (IoMem isa w, w))
-> Text -> Either Text (IoMem isa w, w)
forall a b. (a -> b) -> a -> b
$ Text
"iomemory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr (IoMem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity IoMem isa w
io) Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: input is depleted"
            Just (w
i : [w]
is, [w]
os) -> do
                let io' :: IoMem isa w
io' = IoMem isa w
io{mIoStreams = insert idx (is, os) mIoStreams}
                (IoMem isa w, w) -> Either Text (IoMem isa w, w)
forall a b. b -> Either a b
Right (RW -> Int -> Int -> IoMem isa w -> IoMem isa w
forall isa w. RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordIoAccess RW
R Int
idx (forall t. ByteSizeT t => Int
byteSizeT @w) IoMem isa w
io', w
i)
            Maybe (Val (IntMap ([w], [w])))
Nothing -> do
                (mIoCells', w) <- Mem isa w -> Int -> Either Text (Mem isa w, w)
forall m isa w. Memory m isa w => m -> Int -> Either Text (m, w)
readWord Mem isa w
mIoCells Int
idx
                return (recordDataAccess R idx (byteSizeT @w) io{mIoCells = mIoCells'}, w)

    writeWord :: IoMem isa w -> Int -> w -> Either Text (IoMem isa w)
writeWord IoMem isa w
io Int
idx w
_word
        | IoMem isa w -> Int -> Bool
forall w isa.
(Default w, FiniteBits w) =>
IoMem isa w -> Int -> Bool
ioPortWordCollision IoMem isa w
io Int
idx = Text -> Either Text (IoMem isa w)
forall a b. a -> Either a b
Left (Text -> Either Text (IoMem isa w))
-> Text -> Either Text (IoMem isa w)
forall a b. (a -> b) -> a -> b
$ Text
"iomemory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr (IoMem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity IoMem isa w
io) Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: can't write word to input port"
    writeWord IoMem isa w
io Int
idx w
word =
        case IoMem isa w -> IntMap ([w], [w])
forall isa w. IoMem isa w -> IntMap ([w], [w])
mIoStreams IoMem isa w
io IntMap ([w], [w])
-> Key (IntMap ([w], [w])) -> Maybe (Val (IntMap ([w], [w])))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap ([w], [w]))
idx of
            Just ([w]
is, [w]
os) -> IoMem isa w -> Either Text (IoMem isa w)
forall a b. b -> Either a b
Right (IoMem isa w -> Either Text (IoMem isa w))
-> IoMem isa w -> Either Text (IoMem isa w)
forall a b. (a -> b) -> a -> b
$ RW -> Int -> Int -> IoMem isa w -> IoMem isa w
forall isa w. RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordIoAccess RW
W Int
idx (forall t. ByteSizeT t => Int
byteSizeT @w) IoMem isa w
io{mIoStreams = insert idx (is, word : os) (mIoStreams io)}
            Maybe (Val (IntMap ([w], [w])))
Nothing -> do
                mIoCells' <- Mem isa w -> Int -> w -> Either Text (Mem isa w)
forall m isa w. Memory m isa w => m -> Int -> w -> Either Text m
writeWord (IoMem isa w -> Mem isa w
forall isa w. IoMem isa w -> Mem isa w
mIoCells IoMem isa w
io) Int
idx w
word
                return $ recordDataAccess W idx (byteSizeT @w) io{mIoCells = mIoCells'}

    writeByte :: IoMem isa w -> Int -> Word8 -> Either Text (IoMem isa w)
writeByte IoMem isa w
io Int
idx Word8
_byte
        | IoMem isa w -> Int -> Bool
forall w isa.
(Default w, FiniteBits w) =>
IoMem isa w -> Int -> Bool
ioPortByteCollision IoMem isa w
io Int
idx =
            Text -> Either Text (IoMem isa w)
forall a b. a -> Either a b
Left (Text -> Either Text (IoMem isa w))
-> Text -> Either Text (IoMem isa w)
forall a b. (a -> b) -> a -> b
$ Text
"iomemory[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Text
errAddr (IoMem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity IoMem isa w
io) Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: can't write byte to input port"
    writeByte IoMem isa w
io Int
idx Word8
byte =
        case IoMem isa w -> IntMap ([w], [w])
forall isa w. IoMem isa w -> IntMap ([w], [w])
mIoStreams IoMem isa w
io IntMap ([w], [w])
-> Key (IntMap ([w], [w])) -> Maybe (Val (IntMap ([w], [w])))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Int
Key (IntMap ([w], [w]))
idx of
            Just ([w]
is, [w]
os) -> IoMem isa w -> Either Text (IoMem isa w)
forall a b. b -> Either a b
Right (IoMem isa w -> Either Text (IoMem isa w))
-> IoMem isa w -> Either Text (IoMem isa w)
forall a b. (a -> b) -> a -> b
$ RW -> Int -> Int -> IoMem isa w -> IoMem isa w
forall isa w. RW -> Int -> Int -> IoMem isa w -> IoMem isa w
recordIoAccess RW
W Int
idx Int
1 IoMem isa w
io{mIoStreams = insert idx (is, byteToWord byte : os) (mIoStreams io)}
            Maybe (Val (IntMap ([w], [w])))
Nothing -> do
                mIoCells' <- Mem isa w -> Int -> Word8 -> Either Text (Mem isa w)
forall m isa w.
Memory m isa w =>
m -> Int -> Word8 -> Either Text m
writeByte (IoMem isa w -> Mem isa w
forall isa w. IoMem isa w -> Mem isa w
mIoCells IoMem isa w
io) Int
idx Word8
byte
                return $ recordDataAccess W idx 1 io{mIoCells = mIoCells'}

    dumpCells :: IoMem isa w -> IntMap (Cell isa w)
dumpCells = Mem isa w -> IntMap (Cell isa w)
forall isa w. Mem isa w -> IntMap (Cell isa w)
memoryData (Mem isa w -> IntMap (Cell isa w))
-> (IoMem isa w -> Mem isa w) -> IoMem isa w -> IntMap (Cell isa w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IoMem isa w -> Mem isa w
forall isa w. IoMem isa w -> Mem isa w
mIoCells

    memCapacity :: IoMem isa w -> Int
memCapacity = Mem isa w -> Int
forall m isa w. Memory m isa w => m -> Int
memCapacity (Mem isa w -> Int)
-> (IoMem isa w -> Mem isa w) -> IoMem isa w -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IoMem isa w -> Mem isa w
forall isa w. IoMem isa w -> Mem isa w
mIoCells
    ioPorts :: IoMem isa w -> [Int]
ioPorts = IoMem isa w -> [Int]
forall isa w. IoMem isa w -> [Int]
mIoKeys
    accessLog :: IoMem isa w -> AccessLog
accessLog = AccessSet -> AccessLog
toAccessLog (AccessSet -> AccessLog)
-> (IoMem isa w -> AccessSet) -> IoMem isa w -> AccessLog
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IoMem isa w -> AccessSet
forall isa w. IoMem isa w -> AccessSet
mAccessSet
    memAccessCount :: IoMem isa w -> AccessCount
memAccessCount = IoMem isa w -> AccessCount
forall isa w. IoMem isa w -> AccessCount
mAccessCount