From 0bc37657fec6a04734aa0f1b798d66127c0b852e Mon Sep 17 00:00:00 2001 From: Gautham Ganapathy Date: Fri, 13 Oct 2023 12:37:34 +0100 Subject: [PATCH] Fixed for pedantic stack build --- .github/workflows/ci.yml | 5 +- src/TIS100/Parser/AsmParser.hs | 35 +++++---- src/TIS100/Parser/ConfigParser.hs | 25 +++---- src/TIS100/Sim/CPU.hs | 94 +++++++++++------------- src/TIS100/Sim/Run.hs | 35 ++++----- src/TIS100/Tiles/Inactive.hs | 2 +- src/TIS100/Tiles/T21.hs | 118 ++++++++++++++++-------------- src/TIS100/Tiles/T30.hs | 2 +- tissim/Main.hs | 19 ++--- 9 files changed, 160 insertions(+), 175 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index bcba5f4..ab0343d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,10 +23,7 @@ jobs: steps: - uses: actions/checkout@v3 - - uses: freckle/stack-cache-action@main - with: - stack-yaml: ${{ matrix.stack-yaml }} - - uses: freckle/stack-action@main + - uses: freckle/stack-action@v4 with: stack-yaml: ${{ matrix.stack-yaml }} \ No newline at end of file diff --git a/src/TIS100/Parser/AsmParser.hs b/src/TIS100/Parser/AsmParser.hs index ae69a82..d7fb4b6 100644 --- a/src/TIS100/Parser/AsmParser.hs +++ b/src/TIS100/Parser/AsmParser.hs @@ -2,10 +2,9 @@ module TIS100.Parser.AsmParser where import Control.Monad (void) import Data.IntMap qualified as IM -import Debug.Trace (trace, traceM) import TIS100.Errors (TISError (..), TISErrorCode (..), TISErrorOr) -import TIS100.Parser.Base (Parser, parseInt, parseToken) -import Text.Megaparsec (MonadParsec (eof, label, try), parse, sepBy, sepEndBy, some, (<|>)) +import TIS100.Parser.Base (Parser, parseInt) +import Text.Megaparsec (MonadParsec (eof, try), parse, sepBy, sepEndBy, some, (<|>)) import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space, string) data Register = ACC | NIL | LEFT | RIGHT | UP | DOWN | ANY | LAST @@ -41,7 +40,7 @@ parseLabel = some alphaNumChar parseLabelDef :: Parser LabelOrInstruction parseLabelDef = do label <- parseLabel - char ':' + _ <- char ':' return $ Label label parseRegister :: Parser Register @@ -63,49 +62,49 @@ parseRegisterOrConstant = try (Register <$> parseRegister) <|> Constant <$> pars parseNOP :: Parser LabelOrInstruction parseNOP = do - string "NOP" + _ <- string "NOP" return NOP parseMOV :: Parser LabelOrInstruction parseMOV = do - string "MOV" + _ <- string "MOV" space src <- parseRegisterOrConstant space - char ',' + _ <- char ',' space MOV src <$> parseRegister parseSWP :: Parser LabelOrInstruction parseSWP = do - string "SWP" + _ <- string "SWP" return SWP parseSAV :: Parser LabelOrInstruction parseSAV = do - string "SAV" + _ <- string "SAV" return SAV parseADD :: Parser LabelOrInstruction parseADD = do - string "ADD" + _ <- string "ADD" space ADD <$> parseRegisterOrConstant parseSUB :: Parser LabelOrInstruction parseSUB = do - string "SUB" + _ <- string "SUB" space SUB <$> parseRegisterOrConstant parseNEG :: Parser LabelOrInstruction parseNEG = do - string "NEG" + _ <- string "NEG" return NEG parseJump :: String -> (String -> LabelOrInstruction) -> Parser LabelOrInstruction parseJump ins constructor = do - string ins + _ <- string ins space constructor <$> parseLabel @@ -126,7 +125,7 @@ parseJLZ = parseJump "JLZ" JLZ parseJRO :: Parser LabelOrInstruction parseJRO = do - string "JRO" + _ <- string "JRO" space JRO <$> parseRegisterOrConstant @@ -138,7 +137,7 @@ parseLabelOrInstruction = try parseLabelDef <|> try parseInstruction parseTileAsm :: Parser (Int, TileAsmSource) parseTileAsm = do - char '@' + _ <- char '@' n <- parseInt space labelsOrInstructions <- sepEndBy (try parseLabelOrInstruction') $ try endOfTileProgram @@ -150,12 +149,12 @@ parseTileAsm = do return li endOfTileProgram = void space <|> void (char '@') <|> eof -parseAllAsm :: AsmSource -> Parser AsmSource -parseAllAsm tileSources = do +parseAllAsm :: Parser AsmSource +parseAllAsm = do sources <- sepBy parseTileAsm space return $ IM.fromList sources parseAsm :: String -> TISErrorOr AsmSource -parseAsm asmSrc = case parse (parseAllAsm IM.empty) "tis100src" asmSrc of +parseAsm asmSrc = case parse parseAllAsm "tis100src" asmSrc of Left err -> Left $ TISError TISParseError $ show err Right cfg -> Right cfg diff --git a/src/TIS100/Parser/ConfigParser.hs b/src/TIS100/Parser/ConfigParser.hs index edae506..ea7505f 100644 --- a/src/TIS100/Parser/ConfigParser.hs +++ b/src/TIS100/Parser/ConfigParser.hs @@ -1,17 +1,13 @@ module TIS100.Parser.ConfigParser where -import Control.Monad (replicateM, void) +import Control.Monad (replicateM) import Data.IntMap qualified as IM -import Data.Void (Void) -import Debug.Trace (traceM) -import GHC.IO.Handle (hGetContents) import System.FilePath (takeDirectory, ()) -import System.IO (stdin) import TIS100.Errors (TISError (..), TISErrorCode (TISParseError), TISErrorOr) import TIS100.Parser.Base (Parser, parseInt, parseToken) -import TIS100.Parser.Config (Config (..), IODef, IOSource (..), TileType (..)) -import Text.Megaparsec (MonadParsec (eof, takeWhile1P, try), Parsec, anySingleBut, count, manyTill, oneOf, parse, some, (<|>)) -import Text.Megaparsec.Char (char, printChar, space, spaceChar, string) +import TIS100.Parser.Config (Config (Config, inputs, refOutputs), IODef, IOSource (..), TileType (..)) +import Text.Megaparsec (MonadParsec (eof, try), count, oneOf, parse, some, (<|>)) +import Text.Megaparsec.Char (space, string) data Direction = Input | Output deriving (Eq, Show) @@ -31,11 +27,12 @@ parseRow n = do parseTileType 'C' = Conpute parseTileType 'S' = Stack parseTileType 'D' = Disabled + parseTileType tileType = error $ "Unknown tile type in config: " ++ [tileType] parseIOSource :: Parser IOSource parseIOSource = do space - string "NUMERIC" + _ <- string "NUMERIC" space srcType <- parseToken space @@ -55,16 +52,16 @@ parseIODef = do return (dir, n, src) parseIODefs :: IODef -> IODef -> Parser (IODef, IODef) -parseIODefs inputs outputs = +parseIODefs inputs_ outputs = do try $ do space eof - return $ (inputs, outputs) + return $ (inputs_, outputs) <|> do space (dir, n, iosrc) <- parseIODef - parseIODefs (condInf n dir Input inputs iosrc) (condInf n dir Output outputs iosrc) + parseIODefs (condInf n dir Input inputs_ iosrc) (condInf n dir Output outputs iosrc) where condInf :: Int -> Direction -> Direction -> IODef -> IOSource -> IODef condInf n dir refDir ioSrc ioDef = if dir == refDir then IM.insert n ioDef ioSrc else ioSrc @@ -80,8 +77,8 @@ cfgParser = do space return tilesRow space - (inputs, refOutputs) <- parseIODefs IM.empty IM.empty - return $ Config rows cols tiles inputs IM.empty refOutputs + (inputs_, refOutputs_) <- parseIODefs IM.empty IM.empty + return $ Config rows cols tiles inputs_ IM.empty refOutputs_ parseConfig :: String -> TISErrorOr Config parseConfig cfgSrc = case parse cfgParser "tis100cfg" cfgSrc of diff --git a/src/TIS100/Sim/CPU.hs b/src/TIS100/Sim/CPU.hs index ee0a16b..277788a 100644 --- a/src/TIS100/Sim/CPU.hs +++ b/src/TIS100/Sim/CPU.hs @@ -1,11 +1,9 @@ module TIS100.Sim.CPU where import Control.Monad (zipWithM) -import Control.Monad.RWS (MonadState (get)) import Data.IntMap qualified as IM import Data.Map qualified as M import Data.Vector qualified as V -import Data.Vector.Mutable qualified as MV import TIS100.Errors (TISError (..), TISErrorCode (TISParseError), TISErrorOr) import TIS100.Parser.AsmParser qualified as AP import TIS100.Parser.Config qualified as C @@ -14,13 +12,12 @@ import TIS100.Tiles.ConnectedTile (ConnectedTile (..)) import TIS100.Tiles.Inactive qualified as Inactive import TIS100.Tiles.T21 qualified as T21 import TIS100.Tiles.T30 qualified as T30 -import Text.Read (Lexeme (String)) data Tile = T21' T21.T21 | T30' T30.T30 | Inactive' Inactive.InactiveTile deriving (Eq, Show) data PositionedTile = PositionedTile - { pos :: (Int, Int) + { position :: (Int, Int) , index :: Int , tile :: ConnectedTile } @@ -33,18 +30,15 @@ data CPUConfig = CPUConfig deriving (Eq, Show) data CPUState = CPUState - { cfg :: CPUConfig + { config :: CPUConfig , tiles :: V.Vector PositionedTile } deriving (Eq, Show) createInitialCPUState :: C.Config -> AP.AsmSource -> TISErrorOr CPUState createInitialCPUState cfg asm = - let rows = C.rows cfg - cols = C.cols cfg - numTiles = rows * cols - tileTypes = concat $ C.tiles cfg - in (CPUState (CPUConfig rows cols) . V.fromList <$> zipWithM createTile [0 ..] tileTypes) + let tileTypes = concat $ C.tiles cfg + in (CPUState (CPUConfig (C.rows cfg) (C.cols cfg)) . V.fromList <$> zipWithM createTile [0 ..] tileTypes) where createTile :: Int -> C.TileType -> TISErrorOr PositionedTile createTile i tileType = @@ -59,46 +53,46 @@ createInitialCPUState cfg asm = Nothing -> Left $ TISError TISParseError $ "No tile asm forat index " ++ show i Just a -> resolveAsm a - resolveAsm :: AP.TileAsmSource -> TISErrorOr T21.TileProgram - resolveAsm asm = resolve (locateLabels asm 0 M.empty) asm V.empty - where - locateLabels :: AP.TileAsmSource -> Int -> M.Map String Int -> M.Map String Int - locateLabels [] _ m = m - locateLabels (AP.Label l : xs) pc m = locateLabels xs (pc + 1) (M.insert l pc m) - locateLabels (_ : xs) pc m = locateLabels xs (pc + 1) m +resolveAsm :: AP.TileAsmSource -> TISErrorOr T21.TileProgram +resolveAsm asm = resolve (locateLabels asm 0 M.empty) asm V.empty + where + locateLabels :: AP.TileAsmSource -> Int -> M.Map String Int -> M.Map String Int + locateLabels [] _ m = m + locateLabels (AP.Label l : xs) pc m = locateLabels xs (pc + 1) (M.insert l pc m) + locateLabels (_ : xs) pc m = locateLabels xs (pc + 1) m - resolve :: M.Map String Int -> AP.TileAsmSource -> T21.TileProgram -> TISErrorOr T21.TileProgram - resolve _ [] p = Right p - resolve m (AP.Label l : xs) p = resolve m xs p - resolve m (AP.NOP : xs) p = resolve m xs $ V.snoc p T21.NOP - resolve m (AP.MOV (AP.Register src) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOV (resolveReg src) (resolveReg dst) - resolve m (AP.MOV (AP.Constant srci) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOVI (Tiles.Value srci) (resolveReg dst) - resolve m (AP.SWP : xs) p = resolve m xs $ V.snoc p T21.SWP - resolve m (AP.SAV : xs) p = resolve m xs $ V.snoc p T21.SAV - resolve m (AP.ADD (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.ADD (resolveReg src) - resolve m (AP.ADD (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.ADDI (Tiles.Value srci) - resolve m (AP.SUB (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.SUB (resolveReg src) - resolve m (AP.SUB (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.SUBI (Tiles.Value srci) - resolve m (AP.NEG : xs) p = resolve m xs $ V.snoc p T21.NEG - resolve m (AP.JMP l : xs) p = resolveJump m xs p l $ T21.JMP - resolve m (AP.JEZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.EZ - resolve m (AP.JNZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.NZ - resolve m (AP.JGZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.GZ - resolve m (AP.JLZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.LZ - resolve m (AP.JRO (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.JRO (resolveReg src) - resolve m (AP.JRO (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.JROI (Tiles.Value srci) + resolve :: M.Map String Int -> AP.TileAsmSource -> T21.TileProgram -> TISErrorOr T21.TileProgram + resolve _ [] p = Right p + resolve m (AP.Label _ : xs) p = resolve m xs p + resolve m (AP.NOP : xs) p = resolve m xs $ V.snoc p T21.NOP + resolve m (AP.MOV (AP.Register src) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOV (resolveReg src) (resolveReg dst) + resolve m (AP.MOV (AP.Constant srci) dst : xs) p = resolve m xs $ V.snoc p $ T21.MOVI (Tiles.Value srci) (resolveReg dst) + resolve m (AP.SWP : xs) p = resolve m xs $ V.snoc p T21.SWP + resolve m (AP.SAV : xs) p = resolve m xs $ V.snoc p T21.SAV + resolve m (AP.ADD (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.ADD (resolveReg src) + resolve m (AP.ADD (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.ADDI (Tiles.Value srci) + resolve m (AP.SUB (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.SUB (resolveReg src) + resolve m (AP.SUB (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.SUBI (Tiles.Value srci) + resolve m (AP.NEG : xs) p = resolve m xs $ V.snoc p T21.NEG + resolve m (AP.JMP l : xs) p = resolveJump m xs p l $ T21.JMP + resolve m (AP.JEZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.EZ + resolve m (AP.JNZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.NZ + resolve m (AP.JGZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.GZ + resolve m (AP.JLZ l : xs) p = resolveJump m xs p l $ T21.JCC T21.LZ + resolve m (AP.JRO (AP.Register src) : xs) p = resolve m xs $ V.snoc p $ T21.JRO (resolveReg src) + resolve m (AP.JRO (AP.Constant srci) : xs) p = resolve m xs $ V.snoc p $ T21.JROI (Tiles.Value srci) - resolveJump :: M.Map String Int -> [AP.LabelOrInstruction] -> T21.TileProgram -> String -> (T21.Address -> T21.Instruction) -> TISErrorOr T21.TileProgram - resolveJump m xs p l ins = case M.lookup l m of - Nothing -> Left $ TISError TISParseError $ "Unknown label " ++ l - Just addr -> resolve m xs $ V.snoc p $ ins (T21.Address addr) + resolveJump :: M.Map String Int -> [AP.LabelOrInstruction] -> T21.TileProgram -> String -> (T21.Address -> T21.Instruction) -> TISErrorOr T21.TileProgram + resolveJump m xs p l ins = case M.lookup l m of + Nothing -> Left $ TISError TISParseError $ "Unknown label " ++ l + Just addr -> resolve m xs $ V.snoc p $ ins (T21.Address addr) - resolveReg :: AP.Register -> T21.RegisterOrPort - resolveReg AP.ACC = T21.Register T21.ACC - resolveReg AP.NIL = T21.Register T21.NIL - resolveReg AP.LEFT = T21.Port Tiles.LEFT - resolveReg AP.RIGHT = T21.Port Tiles.RIGHT - resolveReg AP.UP = T21.Port Tiles.UP - resolveReg AP.DOWN = T21.Port Tiles.DOWN - resolveReg AP.ANY = T21.Port Tiles.ANY - resolveReg AP.LAST = T21.Port Tiles.LAST + resolveReg :: AP.Register -> T21.RegisterOrPort + resolveReg AP.ACC = T21.Register T21.ACC + resolveReg AP.NIL = T21.Register T21.NIL + resolveReg AP.LEFT = T21.Port Tiles.LEFT + resolveReg AP.RIGHT = T21.Port Tiles.RIGHT + resolveReg AP.UP = T21.Port Tiles.UP + resolveReg AP.DOWN = T21.Port Tiles.DOWN + resolveReg AP.ANY = T21.Port Tiles.ANY + resolveReg AP.LAST = T21.Port Tiles.LAST diff --git a/src/TIS100/Sim/Run.hs b/src/TIS100/Sim/Run.hs index 1307570..19bb42e 100644 --- a/src/TIS100/Sim/Run.hs +++ b/src/TIS100/Sim/Run.hs @@ -3,19 +3,15 @@ module TIS100.Sim.Run where import Control.Monad import Control.Monad.ST import Data.IntMap qualified as IM -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust) import Data.Vector qualified as MV import Data.Vector qualified as V import Data.Vector.Mutable qualified as MV -import Foreign qualified as V import TIS100.Parser.Config (IODef) import TIS100.Parser.Config qualified as CFG import TIS100.Sim.CPU qualified as CPU import TIS100.Tiles.Base qualified as Tiles -import TIS100.Tiles.ConnectedTile (ConnectedTile (..), IsConnectedTile (..)) -import TIS100.Tiles.Inactive qualified as Inactive -import TIS100.Tiles.T21 qualified as T21 -import TIS100.Tiles.T30 qualified as T30 +import TIS100.Tiles.ConnectedTile (IsConnectedTile (..)) data SimState = SimState { cpu :: CPU.CPUState @@ -26,7 +22,6 @@ data SimState = SimState type RWTileVector = MV.MVector RealWorld CPU.PositionedTile - loopUntilNoChange :: Int -> SimState -> IO SimState loopUntilNoChange i s = do nextSimState <- runStep s @@ -57,22 +52,22 @@ readInputValue :: Int -> CFG.IODef -> IO (Maybe Int, CFG.IODef) readInputValue ti iodef = case IM.lookup ti iodef of Just (CFG.List (v : vs)) -> return (Just v, IM.insert ti (CFG.List vs) iodef) Just (CFG.List []) -> return (Nothing, iodef) - Just (CFG.File fp) -> error "Tile I/O using files is not yet implemented" + Just (CFG.File _) -> error "Tile I/O using files is not yet implemented" Just CFG.StdIO -> error "Tile I/O using StdIO is not yet implemented" Nothing -> return (Nothing, iodef) writeOutputValue :: Int -> Int -> CFG.IODef -> IO CFG.IODef writeOutputValue ti v iodef = case IM.lookup ti iodef of Just (CFG.List vs) -> return $ IM.insert ti (CFG.List (vs ++ [v])) iodef - Just (CFG.File fp) -> error "Tile I/O using files is not yet implemented" + Just (CFG.File _) -> error "Tile I/O using files is not yet implemented" Just CFG.StdIO -> error "Tile I/O using StdIO is not yet implemented" Nothing -> return $ IM.insert ti (CFG.List [v]) iodef processComm :: SimState -> IO SimState -processComm (SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles) ins outs) = do - mtiles <- V.thaw tiles +processComm (SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles_) ins_ outs_) = do + mtiles <- V.thaw tiles_ let nTiles = rows * cols - (mtiles', ins', outs') <- foldM processTileComm' (mtiles, ins, outs) [0 .. nTiles - 1] + (mtiles', ins', outs') <- foldM processTileComm' (mtiles, ins_, outs_) [0 .. nTiles - 1] tiles' <- V.freeze mtiles' return $ SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles') ins' outs' where @@ -84,7 +79,7 @@ processComm (SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles) ins outs) = processTileComm (tiles, ins, outs) i = do ptile <- MV.read tiles i let tile = CPU.tile ptile - let (r, c) = CPU.pos ptile + let (r, c) = CPU.position ptile case getRunState tile of Tiles.WaitingOnRead p -> do @@ -148,15 +143,15 @@ stepTiles :: SimState -> IO SimState stepTiles (SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles) ins outs) = do mtiles <- V.thaw tiles let nTiles = rows * cols - (mtiles', ins', outs') <- foldM stepTile (mtiles, ins, outs) [0 .. nTiles - 1] + mtiles' <- foldM stepTile mtiles [0 .. nTiles - 1] tiles' <- V.freeze mtiles' - return $ SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles') ins' outs' + return $ SimState (CPU.CPUState (CPU.CPUConfig rows cols) tiles') ins outs where - stepTile :: (RWTileVector, IODef, IODef) -> Int -> IO (RWTileVector, IODef, IODef) - stepTile (tiles, ins, outs) i = do - ptile <- MV.read tiles i + stepTile :: RWTileVector -> Int -> IO RWTileVector + stepTile tiles_ i = do + ptile <- MV.read tiles_ i let tile = CPU.tile ptile let tile' = step tile let ptile' = ptile{CPU.tile = tile'} - MV.write tiles i ptile' - return $ (tiles, ins, outs) \ No newline at end of file + MV.write tiles_ i ptile' + return tiles_ \ No newline at end of file diff --git a/src/TIS100/Tiles/Inactive.hs b/src/TIS100/Tiles/Inactive.hs index b9927e1..2eec6e2 100644 --- a/src/TIS100/Tiles/Inactive.hs +++ b/src/TIS100/Tiles/Inactive.hs @@ -1,7 +1,7 @@ module TIS100.Tiles.Inactive where import TIS100.Tiles.Base qualified as Tiles -import TIS100.Tiles.ConnectedTile (ConnectedTile (..), IsConnectedTile (..)) +import TIS100.Tiles.ConnectedTile (IsConnectedTile (..)) data InactiveTile = InactiveTile deriving (Eq, Show) diff --git a/src/TIS100/Tiles/T21.hs b/src/TIS100/Tiles/T21.hs index ab125c7..0a2c055 100644 --- a/src/TIS100/Tiles/T21.hs +++ b/src/TIS100/Tiles/T21.hs @@ -1,12 +1,9 @@ module TIS100.Tiles.T21 where -import Control.Applicative (Applicative (..)) -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Vector qualified as V -import Data.Vector.Generic.New (run) -import GHC.Arr (ixmap) import TIS100.Tiles.Base (Port' (..), RunState (..), Value (..)) -import TIS100.Tiles.ConnectedTile (ConnectedTile (..), IsConnectedTile (..)) +import TIS100.Tiles.ConnectedTile (IsConnectedTile (..)) import Prelude hiding (last) data Register' = ACC | NIL | BAK @@ -55,12 +52,12 @@ data TileState = TileState data T21 = T21 { tileState :: TileState - , program :: TileProgram + , tileProgram :: TileProgram } deriving (Eq, Show) createTileState :: TileProgram -> T21 -createTileState program = +createTileState program_ = T21 { tileState = TileState @@ -74,7 +71,7 @@ createTileState program = , pc = 0 , runState = Ready } - , program = program + , tileProgram = program_ } getTileRunState :: T21 -> RunState @@ -85,10 +82,13 @@ setTileRunState rs tile = tile{tileState = (tileState tile){runState = rs}} getPortVal :: Port' -> T21 -> (T21, Maybe Value) getPortVal p t + | p == ANY = error "Reads from ANY is not supported yet" + | p == LAST = error "Reads from LAST is not supported yet" | p == LEFT = getPortVal' left t{tileState = (tileState t){left = Nothing, runState = rs}} | p == RIGHT = getPortVal' right t{tileState = (tileState t){right = Nothing, runState = rs}} | p == UP = getPortVal' up t{tileState = (tileState t){up = Nothing, runState = rs}} | p == DOWN = getPortVal' down t{tileState = (tileState t){down = Nothing, runState = rs}} + | otherwise = error "Should not reach this code" where getPortVal' f t' = case f $ tileState t of Just v -> (t', Just v) @@ -97,24 +97,33 @@ getPortVal p t setPortVal :: Port' -> Value -> T21 -> T21 setPortVal p v t + | p == ANY = error "Writes to ANY is not supported yet" + | p == LAST = error "Writes to LAST is not supported yet" | p == LEFT = t{tileState = (tileState t){left = Just v, runState = rs}} | p == RIGHT = t{tileState = (tileState t){right = Just v, runState = rs}} | p == UP = t{tileState = (tileState t){up = Just v, runState = rs}} | p == DOWN = t{tileState = (tileState t){down = Just v, runState = rs}} + | otherwise = error "Should not reach this code" where rs = case (runState . tileState) t of - WaitingOnRead p -> Ready - WaitingOnWrite p -> WaitingOnWrite p + WaitingOnRead _ -> Ready + WaitingOnWrite p' -> WaitingOnWrite p' Ready -> WaitingOnWrite p -clearPortVal :: Port' -> Value -> T21 -> T21 -clearPortVal LEFT v t = t{tileState = (tileState t){left = Nothing}} -clearPortVal RIGHT v t = t{tileState = (tileState t){right = Nothing}} -clearPortVal UP v t = t{tileState = (tileState t){up = Nothing}} -clearPortVal DOWN v t = t{tileState = (tileState t){down = Nothing}} +getRegVal :: Register' -> T21 -> Value +getRegVal r t = case r of + ACC -> acc $ tileState t + BAK -> bak $ tileState t + NIL -> Value 0 + +setRegVal :: Register' -> Value -> T21 -> T21 +setRegVal r v t = case r of + ACC -> t{tileState = (tileState t){acc = v}} + BAK -> t{tileState = (tileState t){bak = v}} + NIL -> t getCurrentInstruction :: T21 -> Maybe Instruction -getCurrentInstruction t = program t V.!? ix +getCurrentInstruction t = tileProgram t V.!? ix where (Address ix) = pc $ tileState t @@ -125,13 +134,13 @@ incPC t = else t where (Address pc') = pc $ tileState t - nextPC = Address $ (pc' + 1) `mod` V.length (program t) + nextPC = Address $ (pc' + 1) `mod` V.length (tileProgram t) addValueToPC :: (T21, Maybe Value) -> T21 addValueToPC (t, Just (Value v)) = t{tileState = (tileState t){pc = nextPC}} where (Address pc') = pc $ tileState t - nextPC = Address $ (pc' + v) `mod` V.length (program t) + nextPC = Address $ (pc' + v) `mod` V.length (tileProgram t) addValueToPC (t, Nothing) = t instance IsConnectedTile T21 where @@ -166,12 +175,12 @@ instance IsConnectedTile T21 where writeValueTo = setPortVal - step t = case (runState . tileState) t of - Ready -> stepReady t - WaitingOnRead p -> stepWaitingOnRead t p - WaitingOnWrite p -> stepWaitingOnWrite t p + step t_ = case (runState . tileState) t_ of + Ready -> stepReady t_ + WaitingOnRead p_ -> stepWaitingOnRead t_ p_ + WaitingOnWrite p_ -> stepWaitingOnWrite t_ p_ where - stepWaitingOnWrite _ _ = t + stepWaitingOnWrite t _ = t stepWaitingOnRead :: T21 -> Port' -> T21 stepWaitingOnRead t p = case getCurrentInstruction t of @@ -185,10 +194,10 @@ instance IsConnectedTile T21 where _ -> t stepReady :: T21 -> T21 - stepReady t = fromMaybe t (stepReady' t) + stepReady t = fromMaybe t stepReady' where - stepReady' :: T21 -> Maybe T21 - stepReady' t = case getCurrentInstruction t of + stepReady' :: Maybe T21 + stepReady' = case getCurrentInstruction t of Nothing -> Nothing Just NOP -> Just $ incPC t Just (MOVI v dst) -> Just $ incPC $ writeRegOrPort dst (t, Just v) @@ -209,31 +218,32 @@ instance IsConnectedTile T21 where Just (JROI v) -> Just $ addValueToPC (t, Just v) Just (JRO src) -> Just $ addValueToPC $ readRegOrPort src t maybeAddSub :: (Value -> Value -> Value) -> (T21, Maybe Value) -> (T21, Maybe Value) -> (T21, Maybe Value) - maybeAddSub f (t, Just v1) (_, Just v2) = (t, Just $ f v1 v2) - - readRegOrPort :: RegisterOrPort -> T21 -> (T21, Maybe Value) - readRegOrPort rp t = case rp of - Register r -> (t, Just v) - where - v = case r of - ACC -> acc (tileState t) - BAK -> bak (tileState t) - NIL -> Value 0 - Port p -> getPortVal p t - - writeRegOrPort :: RegisterOrPort -> (T21, Maybe Value) -> T21 - writeRegOrPort rp (t, Just v) = case rp of - Register r -> case r of - ACC -> t{tileState = (tileState t){acc = v}} - BAK -> t{tileState = (tileState t){bak = v}} - NIL -> t - Port p -> setPortVal p v t - writeRegOrPort _ (t, Nothing) = t - - swapAccBak :: T21 -> T21 - swapAccBak t = - let (_, Just acc) = readRegOrPort (Register ACC) t - (_, Just bak) = readRegOrPort (Register BAK) t - t' = writeRegOrPort (Register ACC) (t, Just bak) - t'' = writeRegOrPort (Register BAK) (t', Just acc) - in t'' + maybeAddSub f (t', Just v1) (_, Just v2) = (t', Just $ f v1 v2) + maybeAddSub _ tv _ = tv -- Just to silence the linter + +readRegOrPort :: RegisterOrPort -> T21 -> (T21, Maybe Value) +readRegOrPort rp t = case rp of + Register r -> (t, Just v) + where + v = case r of + ACC -> acc (tileState t) + BAK -> bak (tileState t) + NIL -> Value 0 + Port p -> getPortVal p t + +writeRegOrPort :: RegisterOrPort -> (T21, Maybe Value) -> T21 +writeRegOrPort rp (t, Just v) = case rp of + Register r -> case r of + ACC -> t{tileState = (tileState t){acc = v}} + BAK -> t{tileState = (tileState t){bak = v}} + NIL -> t + Port p -> setPortVal p v t +writeRegOrPort _ (t, Nothing) = t + +swapAccBak :: T21 -> T21 +swapAccBak t = + let accVal = getRegVal ACC t + bakVal = getRegVal BAK t + t' = setRegVal ACC bakVal t + t'' = setRegVal BAK accVal t' + in t'' diff --git a/src/TIS100/Tiles/T30.hs b/src/TIS100/Tiles/T30.hs index 221656f..5c07789 100644 --- a/src/TIS100/Tiles/T30.hs +++ b/src/TIS100/Tiles/T30.hs @@ -1,7 +1,7 @@ module TIS100.Tiles.T30 where import TIS100.Tiles.Base qualified as Tiles -import TIS100.Tiles.ConnectedTile (ConnectedTile (..), IsConnectedTile (..)) +import TIS100.Tiles.ConnectedTile (IsConnectedTile (..)) newtype T30 = T30 [Tiles.Value] deriving (Eq, Show) diff --git a/tissim/Main.hs b/tissim/Main.hs index 6c495f6..939645b 100644 --- a/tissim/Main.hs +++ b/tissim/Main.hs @@ -1,16 +1,9 @@ module Main where import CmdLine (parseCmdLine) -import Control.Monad (foldM, replicateM, void) -import Data.Either (fromRight) -import Data.IntMap qualified as IM -import Data.Vector qualified as V -import TIS100.Parser.AsmParser (AsmSource, parseAsm) import TIS100.Parser.Config qualified as ParserCfg -import TIS100.Parser.ConfigParser (parseConfig, readExternalInputs) import TIS100.Parser.Util qualified as ParserUtil import TIS100.Sim.CPU qualified as CPU -import TIS100.Sim.Config (ConfigSource (..), SimRunConfig (..)) import TIS100.Sim.Run qualified as Run main :: IO () @@ -28,11 +21,11 @@ main = do Left err -> error $ show err Right cpuState -> Run.run $ Run.SimState cpuState (ParserCfg.inputs cfg) (ParserCfg.outputs cfg) - print "" - print "Final state" + putStrLn "" + putStrLn "Final state" print finalSimState - print "Ref Output" - print $ show $ ParserCfg.refOutputs cfg - print "Test Output" - print $ show $ Run.outputs finalSimState + putStrLn "Ref Output" + print $ ParserCfg.refOutputs cfg + putStrLn "Test Output" + print $ Run.outputs finalSimState return ()