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

module Wrench.Machine (powerOn) where

import Relude
import Relude.Extra
import Wrench.Machine.Types

data Simulation st isa = Simulation
    { forall st isa. Simulation st isa -> [Trace st isa]
log :: [Trace st isa]
    , forall st isa. Simulation st isa -> st
machineState :: st
    , forall st isa. Simulation st isa -> HashMap Int Text
pc2label :: HashMap Int Text
    , forall st isa. Simulation st isa -> Int
instructionCount :: Int
    , forall st isa. Simulation st isa -> Int
instructionLimits :: Int
    , forall st isa. Simulation st isa -> Int
stateRecordCount :: Int
    , forall st isa. Simulation st isa -> Int
stateRecordLimits :: Int
    , forall st isa. Simulation st isa -> Int
takePartOnStateRecordLimit :: Int
    }

tellState :: Maybe isa -> st -> State (Simulation st isa) ()
tellState :: forall isa st. Maybe isa -> st -> State (Simulation st isa) ()
tellState Maybe isa
prevInstr st
machineState = (Simulation st isa -> Simulation st isa)
-> StateT (Simulation st isa) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Simulation st isa -> Simulation st isa)
 -> StateT (Simulation st isa) Identity ())
-> (Simulation st isa -> Simulation st isa)
-> StateT (Simulation st isa) Identity ()
forall a b. (a -> b) -> a -> b
$
    \sim :: Simulation st isa
sim@Simulation{[Trace st isa]
log :: forall st isa. Simulation st isa -> [Trace st isa]
log :: [Trace st isa]
log, Int
stateRecordCount :: forall st isa. Simulation st isa -> Int
stateRecordCount :: Int
stateRecordCount, Int
stateRecordLimits :: forall st isa. Simulation st isa -> Int
stateRecordLimits :: Int
stateRecordLimits, Int
takePartOnStateRecordLimit :: forall st isa. Simulation st isa -> Int
takePartOnStateRecordLimit :: Int
takePartOnStateRecordLimit, Int
instructionCount :: forall st isa. Simulation st isa -> Int
instructionCount :: Int
instructionCount} ->
        if Int
stateRecordCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
stateRecordLimits
            then
                let n :: Int
n = (Int
stateRecordLimits Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
takePartOnStateRecordLimit)
                    rest :: [Trace st isa]
rest = Int -> [Trace st isa] -> [Trace st isa]
forall a. Int -> [a] -> [a]
drop Int
n [Trace st isa]
log
                    rest' :: [Trace st isa]
rest' =
                        (Trace st isa -> Bool) -> [Trace st isa] -> [Trace st isa]
forall a. (a -> Bool) -> [a] -> [a]
filter
                            ( \case
                                TState{} -> Bool
False
                                Trace st isa
_ -> Bool
True
                            )
                            [Trace st isa]
rest
                    dropped :: Int
dropped = [Trace st isa] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Trace st isa]
rest Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Trace st isa] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Trace st isa]
rest'
                    warn :: Text
warn = Text
"Dropped " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
dropped Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" states"
                 in Simulation st isa
sim
                        { log = take n log <> rest' <> [TWarn warn]
                        , stateRecordCount = stateRecordCount - dropped
                        }
            else
                Simulation st isa
sim
                    { log = TState{tInstructionCount = instructionCount, tPrevInstruction = prevInstr, tState = machineState} : log
                    , stateRecordCount = stateRecordCount + 1
                    }

tellError :: Text -> m ()
tellError Text
msg = (Simulation st isa -> Simulation st isa) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Simulation st isa -> Simulation st isa) -> m ())
-> (Simulation st isa -> Simulation st isa) -> m ()
forall a b. (a -> b) -> a -> b
$ \sim :: Simulation st isa
sim@Simulation{[Trace st isa]
log :: forall st isa. Simulation st isa -> [Trace st isa]
log :: [Trace st isa]
log} ->
    Simulation st isa
sim{log = TError msg : log}

-- | Run the simulation and return both the recorded trace log and the final
--   machine state. The final state carries the complete runtime accumulators
--   (e.g. 'AccessLog' in 'IoMem'); per-state trace entries are recorded
--   after each step, so the last entry captures the result of the halt
--   instruction too.
simulate :: (Machine st isa w) => Simulation st isa -> ([Trace st isa], st)
simulate :: forall st isa w.
Machine st isa w =>
Simulation st isa -> ([Trace st isa], st)
simulate Simulation st isa
sim =
    let Simulation{[Trace st isa]
log :: forall st isa. Simulation st isa -> [Trace st isa]
log :: [Trace st isa]
log, st
machineState :: forall st isa. Simulation st isa -> st
machineState :: st
machineState} = State (Simulation st isa) ()
-> Simulation st isa -> Simulation st isa
forall s a. State s a -> s -> s
execState (Maybe isa -> State (Simulation st isa) ()
forall st isa w.
Machine st isa w =>
Maybe isa -> State (Simulation st isa) ()
simulate' Maybe isa
forall a. Maybe a
Nothing) Simulation st isa
sim
     in ([Trace st isa] -> [Trace st isa]
forall a. [a] -> [a]
reverse [Trace st isa]
log, st
machineState)

simulateInstructionStep :: (Machine st isa w) => Int -> isa -> st -> State (Simulation st isa) ()
simulateInstructionStep :: forall st isa w.
Machine st isa w =>
Int -> isa -> st -> State (Simulation st isa) ()
simulateInstructionStep Int
pc isa
instr st
fetched =
    (Simulation st isa -> Simulation st isa)
-> StateT (Simulation st isa) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Simulation st isa -> Simulation st isa)
 -> StateT (Simulation st isa) Identity ())
-> (Simulation st isa -> Simulation st isa)
-> StateT (Simulation st isa) Identity ()
forall a b. (a -> b) -> a -> b
$ \sim :: Simulation st isa
sim@Simulation{Int
instructionCount :: forall st isa. Simulation st isa -> Int
instructionCount :: Int
instructionCount} ->
        Simulation st isa
sim
            { machineState = execState (instructionExecute pc instr) fetched
            , instructionCount = instructionCount + 1
            }

simulate' :: (Machine st isa w) => Maybe isa -> State (Simulation st isa) ()
simulate' :: forall st isa w.
Machine st isa w =>
Maybe isa -> State (Simulation st isa) ()
simulate' Maybe isa
prevInstr = do
    Simulation{machineState, instructionCount, instructionLimits} <- StateT (Simulation st isa) Identity (Simulation st isa)
forall s (m :: * -> *). MonadState s m => m s
get
    if instructionCount >= instructionLimits
        then tellError "Simulation limit reached"
        else case runState instructionFetch machineState of
            (Right (Int
pc, isa
instr), st
fetched) -> do
                Maybe isa -> st -> StateT (Simulation st isa) Identity ()
forall isa st. Maybe isa -> st -> State (Simulation st isa) ()
tellState Maybe isa
prevInstr st
machineState
                Int -> isa -> st -> StateT (Simulation st isa) Identity ()
forall st isa w.
Machine st isa w =>
Int -> isa -> st -> State (Simulation st isa) ()
simulateInstructionStep Int
pc isa
instr st
fetched
                Maybe isa -> StateT (Simulation st isa) Identity ()
forall st isa w.
Machine st isa w =>
Maybe isa -> State (Simulation st isa) ()
simulate' (isa -> Maybe isa
forall a. a -> Maybe a
Just isa
instr)
            (Left Text
err, st
_) | Text
err Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
halted -> do
                Simulation{machineState = stateAfter} <- StateT (Simulation st isa) Identity (Simulation st isa)
forall s (m :: * -> *). MonadState s m => m s
get
                tellState prevInstr stateAfter
            (Left Text
err, st
_) -> Text -> StateT (Simulation st isa) Identity ()
forall {st} {isa} {m :: * -> *}.
MonadState (Simulation st isa) m =>
Text -> m ()
tellError Text
err

powerOn ::
    (IsWord w, Machine st isa w) =>
    Int
    -> Int
    -> HashMap Text w
    -> st
    -> Either Text ([Trace st isa], st)
powerOn :: forall w st isa.
(IsWord w, Machine st isa w) =>
Int
-> Int -> HashMap Text w -> st -> Either Text ([Trace st isa], st)
powerOn Int
instructionLimits Int
stateRecordLimits HashMap Text w
labels st
machineInitState = do
    let pc2label :: HashMap Int Text
pc2label = [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
    ([Trace st isa], st) -> Either Text ([Trace st isa], st)
forall a b. b -> Either a b
Right (([Trace st isa], st) -> Either Text ([Trace st isa], st))
-> ([Trace st isa], st) -> Either Text ([Trace st isa], st)
forall a b. (a -> b) -> a -> b
$
        Simulation st isa -> ([Trace st isa], st)
forall st isa w.
Machine st isa w =>
Simulation st isa -> ([Trace st isa], st)
simulate
            Simulation
                { log :: [Trace st isa]
log = []
                , machineState :: st
machineState = st
machineInitState
                , pc2label :: HashMap Int Text
pc2label = HashMap Int Text
pc2label
                , instructionCount :: Int
instructionCount = Int
0
                , Int
instructionLimits :: Int
instructionLimits :: Int
instructionLimits
                , stateRecordCount :: Int
stateRecordCount = Int
0
                , Int
stateRecordLimits :: Int
stateRecordLimits :: Int
stateRecordLimits
                , takePartOnStateRecordLimit :: Int
takePartOnStateRecordLimit = Int
4
                }