From a0df5c6aec6ff0271ab47205f915e4647fbad4ec Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sun, 30 Jul 2023 15:42:39 +0100 Subject: [PATCH] Done tracing --- src/Main.hs | 49 ++++++++++++++++++++++++++++++++++++++---- src/SynacorEngine.hs | 51 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 95 insertions(+), 5 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0c9ceea..be6e522 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -28,6 +28,8 @@ data SynacorState = SynacorState , _ssContinue :: Bool , _ssUnsaved :: Bool , _ssState :: [ExecutionState] + , _ssTracing :: Bool + , _ssDumpFile :: String } deriving (Ord, Eq) makeLenses ''SynacorState @@ -42,6 +44,8 @@ instance Show SynacorState , "conts " ++ (show $ state ^. ssContinue) , "unsaved " ++ (show $ state ^. ssUnsaved) , "states " ++ (show $ state ^. ssState) + , "tracing " ++ (show $ state ^. ssTracing) + , "dumping to " ++ (state ^. ssDumpFile) ] main :: IO () @@ -77,19 +81,43 @@ emptyState :: IO SynacorState emptyState = do mem <- getMemory let machine = makeMachine mem - return $ SynacorState [machine] [] [] True False [Runnable] + return $ SynacorState + { _ssMachines = [machine] + , _ssInputs = [] + , _ssOutputs = [] + , _ssContinue = True + , _ssUnsaved = False + , _ssState = [Runnable] + , _ssTracing = False + , _ssDumpFile = "" + } + -- [machine] [] [] True False [Runnable] adventureHarness :: SynacorState -> IO SynacorState adventureHarness state = do command <- prompt "> " state' <- handleCommand command state - let newOutput = head $ state' ^. ssOutputs + let traceAndOutput = head $ state' ^. ssOutputs + let (newOutput, tracing) = spliceOut traceAndOutput putStrLn newOutput + when (state' ^. ssTracing) + (appendFile (state' ^. ssDumpFile) $ unlines tracing) if (state' ^. ssContinue) then (adventureHarness state') else return state' +spliceOut :: String -> (String, [String]) +spliceOut s = doingOut s "" [] + where doingOut s out traces + | null s = (reverse out, reverse traces) + | ">> " `isPrefixOf` s = doingTrace (drop 3 s) out traces "" + | otherwise = doingOut (tail s) (head s : out) traces + doingTrace s out traces tr + | "<<" `isPrefixOf` s = doingOut (drop 2 s) out (reverse tr : traces) + | otherwise = doingTrace (tail s) out traces (head s : tr) + + handleCommand :: String -> SynacorState -> IO SynacorState handleCommand ":quit" state = return $ state & ssContinue .~ False handleCommand ":save" state = @@ -102,7 +130,7 @@ handleCommand ":load" state = machineInput <- readFile filename let inputs = lines machineInput initialState <- emptyState - let nonComments = filter (\i -> head i == '#') inputs + let nonComments = filter (\i -> head i /= '#') inputs let state = foldl' runOneInput initialState ("" : nonComments) return $ state & ssUnsaved .~ False handleCommand ":undo" state = @@ -121,6 +149,16 @@ handleCommand ":recap" state = putStrLn o ) return state +handleCommand ":trace" state = + do filename <- prompt "Dump to? " + return $ state & ssTracing .~ True & ssDumpFile .~ filename +handleCommand ":untrace" state = + return $ state & ssTracing .~ False & ssDumpFile .~ "" +handleCommand ":poke8" state = + do let machines = state ^. ssMachines + let machine = head machines + let machine' = machine & registers . ix 7 .~ 1 + return $ state & ssMachines .~ (machine' : (tail machines)) handleCommand command state = return $ runOneInput state command @@ -141,7 +179,10 @@ runOneInput state input = state & ssMachines %~ (machine' :) & ssContinue .~ True & ssUnsaved .~ True & ssState %~ (exState :) - where machine = head $ state ^. ssMachines + where machine0 = head $ state ^. ssMachines + machine = if (state ^. ssTracing) + then machine0 & tracing .~ True + else machine0 & tracing .~ False inputW = wordify (input ++ "\n") (exState, machine', output) = runMachine inputW (machine & inputIndex .~ 0) -- output' = trace ("runone " ++ (show (machine == machine')) ++ " " ++ (show exState) ++ " " ++ (showOutput output)) output diff --git a/src/SynacorEngine.hs b/src/SynacorEngine.hs index e036f5c..cbd5e04 100644 --- a/src/SynacorEngine.hs +++ b/src/SynacorEngine.hs @@ -11,6 +11,7 @@ import qualified Data.Map.Strict as M import Data.Map.Strict ((!)) import Control.Lens import Data.List +import Data.Char import Numeric import Control.Monad.State.Strict @@ -27,6 +28,7 @@ data Machine = Machine { _memory :: Memory , _registers :: Memory , _inputIndex :: Int , _stack :: [Word16] + , _tracing :: Bool } deriving (Show, Eq, Ord) makeLenses ''Machine @@ -48,6 +50,7 @@ makeMachine memory = Machine , _registers = M.fromList [ (r, 0) | r <- [0..7] ] , _memory = memory , _stack = [] + , _tracing = False } -- traceMachine x = @@ -85,6 +88,7 @@ makeMachine memory = Machine runAll :: ProgrammedMachine ExecutionState runAll = do cip <- gets _ip opcode <- getLocation cip + traceMachine -- opcode' <- traceMachine opcode -- exState <- runStep opcode' exState <- runStep opcode @@ -251,7 +255,7 @@ runStep 20 = else do let char = (inputs!!iIndex) putValue tgt char modify (\m -> m & inputIndex %~ (+ 1)) - advanceIP 2 + advanceIP 2 return Runnable runStep 21 = @@ -262,6 +266,51 @@ runStep _ = return Runnable +traceMachine :: ProgrammedMachine () +traceMachine = do + isTracing <- gets _tracing + when isTracing + do cip <- gets _ip + opcode <- getLocation cip + a <- getLocation (cip + 1) + b <- getLocation (cip + 2) + c <- getLocation (cip + 3) + let sa = show a + let sb = show b + let sc = show c + va <- getValue (cip + 1) + vb <- getValue (cip + 2) + vc <- getValue (cip + 3) + let sva = show va + let svb = show vb + let svc = show vc + let traceText = + case opcode of + 0 -> ["halt"] + 1 -> ["set", sa, sb, "*", sva, svb] + 2 -> ["push", sa, "*", sva] + 3 -> ["pop", sa, "*", sva] + 4 -> ["eq", sa, sb, sc, "*", sva, svb, svc] + 5 -> ["gt", sa, sb, sc, "*", sva, svb, svc] + 6 -> ["jmp", sa, "*", sva] + 7 -> ["jt", sa, sb, "*", sva, svb] + 8 -> ["jf", sa, sb, "*", sva, svb] + 9 -> ["add", sa, sb, sc, "*", sva, svb, svc] + 10 -> ["mul", sa, sb, sc, "*", sva, svb, svc] + 11 -> ["mod", sa, sb, sc, "*", sva, svb, svc] + 12 -> ["and", sa, sb, sc, "*", sva, svb, svc] + 13 -> ["or", sa, sb, sc, "*", sva, svb, svc] + 14 -> ["not", sa, sb, "*", sva, svb] + 15 -> ["rmem", sa, sb, "*", sva, svb] + 16 -> ["wmem", sa, sb, "*", sva, svb] + 17 -> ["call", sa, "*", sva] + 18 -> ["ret"] + 19 -> ["out", sa, "*", sva] + 20 -> ["in", sa, "*", sva] + 21 -> ["noop", sa, sb, sc, "*", sva, svb, svc] + _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc] + tell $ fmap (fromIntegral . ord) (">> " ++ (show cip) ++ ": " ++ (intercalate " " traceText) ++ "<<") + getValue :: Word16 -> ProgrammedMachine Word16 getValue loc = do mem <- gets _memory -- 2.34.1