diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anatoly Krivolapov (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +DCPU-16 Emulator & Assembler +=============== +DCPU-16 is a 16-bit processor designed by Markus "Notch" Persson for the postponed video game 0x10c. + +Features +-------- +- Full spec 1.1 implementation +- Loads binary programs +- Loads assembler programs +- Graphics mode support: 128 x 96 screen +- Sprites +- Keyboard input +- Runs pacman diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import qualified Dcpu16 as D +import System.FilePath (takeExtension) +import Options.Applicative +import Data.Char + +data Opts = Opts { prog :: String } + +opts :: Parser Opts +opts = Opts <$> argument str (metavar "PROG" <> help "assembler or binary program" ) + +main :: IO () +main = do + (Opts prog) <- execParser fullOpts + emu <- D.newEmulator + let isAsm = map toLower (takeExtension prog) `elem` [".asm", ".dasm16"] + if isAsm + then do putStrLn $ "Loading asm program " ++ prog + D.loadAsmProgram emu prog + else do putStrLn $ "Loading binary program " ++ prog + D.loadBinaryProgram emu prog + D.runEmulatorLoop emu + where + fullOpts = info (helper <*> opts) (fullDesc <> progDesc "DCPU-16 Emulator") diff --git a/dcpu16.cabal b/dcpu16.cabal new file mode 100644 --- /dev/null +++ b/dcpu16.cabal @@ -0,0 +1,57 @@ +name: dcpu16 +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/githubuser/dcpu16#readme +license: BSD3 +license-file: LICENSE +author: Anatoly Krivolapov +maintainer: example@example.com +copyright: 2016 Anatoly Krivolapov +category: Compilers/Interpreters +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Dcpu16 + , Dcpu16.Cpu + , Dcpu16.Emulator + , Dcpu16.Video + , Dcpu16.Dumper + , Dcpu16.Assembler + , Dcpu16.Assembler.Syntax + , Dcpu16.Assembler.Parser + other-modules: Dcpu16.Utils + build-depends: base >= 4.7 && < 5 + , sdl2 + , vector + , bytestring + , parsec + , containers + , spool + default-language: Haskell2010 + +executable dcpu16-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , dcpu16 + , optparse-applicative + , filepath + default-language: Haskell2010 + +test-suite dcpu16-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , dcpu16 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/anatolat/dcpu16 diff --git a/src/Dcpu16.hs b/src/Dcpu16.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16.hs @@ -0,0 +1,6 @@ +module Dcpu16 (module X) where + +import Dcpu16.Emulator as X +import Dcpu16.Cpu as X +import Dcpu16.Dumper as X +import Dcpu16.Assembler as X diff --git a/src/Dcpu16/Assembler.hs b/src/Dcpu16/Assembler.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Assembler.hs @@ -0,0 +1,108 @@ +module Dcpu16.Assembler + ( module Dcpu16.Assembler.Syntax + , module Dcpu16.Assembler.Parser + , compileFile + , compileFileToVec + , compileInstructions + ) where + +import Dcpu16.Cpu +import Dcpu16.Utils +import Dcpu16.Assembler.Syntax +import Dcpu16.Assembler.Parser +import Data.Word +import Data.List (foldl') +import Control.Monad (foldM_) +import Data.Bits +import qualified Data.Map.Strict as Map +import qualified Data.Vector.Storable.Mutable as MV +import qualified Data.Vector.Storable as SV + +buildLabelMap :: [AInstr] -> (Map.Map String Int, Int) +buildLabelMap = foldl' go (Map.empty, 0) + where go (mp, offs) (AInstrLabel sym) = (Map.insert sym offs mp, offs) + go (mp, offs) instr = (mp, offs + asmInstrSize instr) + +resolveAsmValue :: AValue -> Map.Map String Int -> Value +resolveAsmValue (AValue value) _ = value +resolveAsmValue (AValueSym value) labelMap = + ValueSymLit $ fromIntegral $ labelMap Map.! value +resolveAsmValue (AValueSymAddr value) labelMap = + ValueAddr $ fromIntegral $ labelMap Map.! value +resolveAsmValue (AValueSymAddrPlusLit label w) labelMap = + ValueSymLit $ fromIntegral (labelMap Map.! label) + w +resolveAsmValue (AValueSymAddrPlusReg label reg) labelMap = + ValueAddrRegPlus reg $ fromIntegral $ labelMap Map.! label + +resolveAsmInstruction :: Map.Map String Int -> AInstr -> [InstrItem] +resolveAsmInstruction labelMap (AInstr instr a b) = [(instr, resolveAsmValue a labelMap, resolveAsmValue b labelMap)] +resolveAsmInstruction _ (AInstrDat ws) = map (\w -> (Dat, ValueLit w, ValueLit 0)) ws +resolveAsmInstruction _ (AInstrLabel _) = [] + +resolveAsmInstructions :: Map.Map String Int -> [AInstr] -> [InstrItem] +resolveAsmInstructions labelMap = concatMap $ resolveAsmInstruction labelMap + +compileValue :: Value -> MV.IOVector Word16 -> Int -> IO (Word16, Int) +compileValue (ValueReg reg) _ ptr = return (wreg, ptr) + where wreg = fromIntegral $ fromEnum reg +compileValue (ValueAddrReg reg) _ ptr = return (wreg + 0x08, ptr) + where wreg = fromIntegral $ fromEnum reg +compileValue (ValueAddrRegPlus reg nw) buf ptr = do + let wreg = fromIntegral $ fromEnum reg + MV.write buf ptr nw + return (wreg + 0x10, ptr + 1) +compileValue ValuePop _ ptr = return (0x18, ptr) +compileValue ValuePeek _ ptr = return (0x19, ptr) +compileValue ValuePush _ ptr = return (0x1a, ptr) +compileValue ValueSP _ ptr = return (0x1b, ptr) +compileValue ValuePC _ ptr = return (0x1c, ptr) +compileValue ValueO _ ptr = return (0x1d, ptr) +compileValue (ValueAddr nw) buf ptr = do + MV.write buf ptr nw + return (0x1e, ptr + 1) +compileValue (ValueLit nw) buf ptr = + if nw <= 0x1f + then return (0x20 + nw, ptr) + else MV.write buf ptr nw >> return (0x1f, ptr + 1) +compileValue (ValueSymLit nw) buf ptr = do + MV.write buf ptr nw + return (0x1f, ptr + 1) + +compileInstr :: InstrItem -> MV.IOVector Word16 -> Int -> IO Int +compileInstr (Dat, ValueLit w, _) buf ptr = do + --putStrLn $ "compile Dat " ++ show a + MV.write buf ptr w + return $ ptr + 1 +-- a non-basic insruction format: aaaaaaoooooo0000 +compileInstr (Jsr, a, _) buf ptr = do + --putStrLn $ "compile Jsr " ++ show a + (wa, ptr') <- compileValue a buf $ ptr + 1 + let wop = fromIntegral $ fromEnum 1 + let w = (wa `shiftL` 10) .|. (wop `shiftL` 4) + MV.write buf ptr w + return ptr' +-- a basic instruction format: bbbbbbaaaaaaoooo +compileInstr (instr, a, b) buf ptr = do + --putStrLn $ "compile " ++ show instr ++ " " ++ show a ++ ", " ++ show b + (wa, ptr') <- compileValue a buf $ ptr + 1 + (wb, ptr'') <- compileValue b buf ptr' + let wop = fromIntegral $ fromEnum instr + 1 + let w = wop .|. (wa `shiftL` 4) .|. (wb `shiftL` 10) + MV.write buf ptr w + return ptr'' + +compileInstructions :: [AInstr] -> IO (SV.Vector Word16) +compileInstructions asmInstrs = do + let (labelMap, size) = buildLabelMap asmInstrs + let instrs = resolveAsmInstructions labelMap asmInstrs + buf <- MV.new size + foldM_ (\ptr instr -> compileInstr instr buf ptr) 0 instrs + SV.unsafeFreeze buf + +compileFileToVec :: FilePath -> IO (SV.Vector Word16) +compileFileToVec src = parseFile src >>= compileInstructions + +compileFile :: FilePath -> FilePath -> IO () +compileFile src dst = do + vec <- compileFileToVec src + writeVectorToFile vec dst diff --git a/src/Dcpu16/Assembler/Parser.hs b/src/Dcpu16/Assembler/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Assembler/Parser.hs @@ -0,0 +1,156 @@ +module Dcpu16.Assembler.Parser + ( parseString + , parseFile + ) where + +import Dcpu16.Cpu +import Dcpu16.Assembler.Syntax +import Text.Parsec +import Text.Parsec.Language (emptyDef) +import Data.Word +import Data.Char +import qualified Control.Applicative as A +import qualified Text.Parsec.Token as Token + +type Parser = Parsec String () + +id2regTable = + [ ("A", RegA) + , ("B", RegB) + , ("C", RegC) + , ("X", RegX) + , ("Y", RegY) + , ("Z", RegZ) + , ("I", RegI) + , ("J", RegJ) + , ("PC", RegPC) + , ("SP", RegSP) + , ("O", RegEx) + ] + +id2valueTable = + [ ("POP", ValuePop) + , ("PEEK", ValuePeek) + , ("PUSH", ValuePush) + , ("PC", ValuePC) + , ("SP", ValueSP) + , ("O", ValueO) + ] + +id2instrTable = + [ ("SET", Set) + , ("ADD", Add) + , ("SUB", Sub) + , ("MUL", Mul) + , ("DIV", Div) + , ("MOD", Mod) + , ("SHL", Shl) + , ("SHR", Shr) + , ("AND", And) + , ("BOR", Bor) + , ("XOR", Xor) + , ("IFE", Ife) + , ("IFN", Ifn) + , ("IFG", Ifg) + , ("IFB", Ifb) + , ("JSR", Jsr) + ] + +lexer = Token.makeTokenParser langDef + where + langDef = emptyDef + { Token.identStart = letter <|> char '_' + , Token.identLetter = alphaNum <|> char '_' + , Token.commentLine = ";" + , Token.caseSensitive = False + } + +parseString :: String -> [AInstr] +parseString str = case runParser toplevel () "" str of + Left e -> error $ show e + Right t -> t + +parseFile :: FilePath -> IO [AInstr] +parseFile filePath = parseString <$> readFile filePath + +colon = Token.colon lexer +comma = Token.comma lexer +ident = Token.identifier lexer + +toplevel :: Parser [AInstr] +toplevel = Token.whiteSpace lexer *> many stmt <* eof + +datStmt :: Parser AInstr +datStmt = AInstrDat <$> (Token.reserved lexer "dat" *> Token.commaSep1 lexer literal) + +name2instr :: String -> Maybe Instr +name2instr name = lookup (map toUpper name) id2instrTable + +instrStmt :: Parser AInstr +instrStmt = do + name <- ident + instr <- maybe (unexpected $ "Unknown instruction " ++ name) return $ name2instr name + a <- value + b <- case instr of + Jsr -> return $ AValue $ ValueLit 0 -- placeholder value + _ -> comma >> value + return $ AInstr instr a b + +stmt :: Parser AInstr +stmt = (AInstrLabel . map toUpper) <$> (colon *> ident) + <|> datStmt + <|> instrStmt + "stmt" + +literal :: Parser Word16 +literal = fromIntegral <$> Token.integer lexer + +value :: Parser AValue +value = term False + <|> Token.brackets lexer (term True) + "value" + +toAddrValue :: AValue -> Maybe AValue +toAddrValue (AValue (ValueReg r)) = Just $ AValue $ ValueAddrReg r +toAddrValue (AValue (ValueLit v)) = Just $ AValue $ ValueAddr v +toAddrValue (AValueSym v) = Just $AValueSymAddr v +toAddrValue _ = Nothing + +sumValues :: AValue -> AValue -> Maybe AValue +sumValues (AValue (ValueLit a)) (AValue (ValueLit b)) = Just $ AValue $ ValueLit $ a + b +sumValues _ _ = Nothing + +sumAddrValues' :: AValue -> AValue -> Maybe AValue +sumAddrValues' (AValue (ValueLit a)) (AValue (ValueLit b)) = Just $ AValue $ ValueAddr $ a + b +sumAddrValues' (AValue (ValueReg a)) (AValue (ValueLit b)) = Just $ AValue $ ValueAddrRegPlus a b +sumAddrValues' (AValueSym a) (AValue (ValueLit b)) = Just $ AValueSymAddrPlusLit a b +sumAddrValues' (AValueSym a) (AValue (ValueReg b)) = Just $ AValueSymAddrPlusReg a b +sumAddrValues' _ _ = Nothing + +sumAddrValues :: AValue -> AValue -> Maybe AValue +sumAddrValues a b = sumAddrValues' a b A.<|> sumAddrValues b a + +term :: Bool -> Parser AValue +term addr = do + values <- sepBy1 atom (Token.reservedOp lexer "+") + let v = case values of + [x] | addr -> toAddrValue x + [x] -> Just x + [x, y] | addr -> sumAddrValues x y + [x, y] -> sumValues x y + _ -> Nothing + + maybe (unexpected "Unexpected term") return v + +name2value :: String -> AValue +name2value name' = + case (lookup name id2valueTable, lookup name id2regTable) of + (Just v, _) -> AValue v + (Nothing, Just reg) -> AValue $ ValueReg reg + (Nothing, Nothing) -> AValueSym name + where name = map toUpper name' + +atom :: Parser AValue +atom = (AValue . ValueLit) <$> literal + <|> name2value <$> ident + "atom value" diff --git a/src/Dcpu16/Assembler/Syntax.hs b/src/Dcpu16/Assembler/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Assembler/Syntax.hs @@ -0,0 +1,34 @@ +module Dcpu16.Assembler.Syntax where + +import Data.Word +import Dcpu16.Cpu + +data AValue = AValue Value + | AValueSym String -- symbol + | AValueSymAddr String -- [symbol] + | AValueSymAddrPlusLit String Word16 -- [symbol + lit] + | AValueSymAddrPlusReg String Reg -- [symbol + reg] + deriving (Show) + +data AInstr = AInstr Instr AValue AValue + | AInstrDat [Word16] + | AInstrLabel String + deriving (Show) + + +valueSize :: Value -> Int +valueSize (ValueAddrRegPlus _ _) = 1 +valueSize (ValueAddr _ ) = 1 +valueSize (ValueLit w) = if w <= 0x1f then 0 else 1 +valueSize (ValueSymLit 0) = 0 +valueSize _ = 0 + +asmValueSize :: AValue -> Int +asmValueSize (AValue value) = valueSize value +asmValueSize _ = 1 + +asmInstrSize :: AInstr -> Int +asmInstrSize (AInstr Jsr a _) = 1 + asmValueSize a +asmInstrSize (AInstr _ a b) = 1 + asmValueSize a + asmValueSize b +asmInstrSize (AInstrDat ws) = length ws +asmInstrSize (AInstrLabel _) = 0 diff --git a/src/Dcpu16/Cpu.hs b/src/Dcpu16/Cpu.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Cpu.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module Dcpu16.Cpu where + +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Storable.Mutable as MV +import Data.Word +import Data.Bits +import Control.Monad +import Control.Applicative ((<$>)) + +screenWidth = 128 :: Int +screenHeight = 96 :: Int +screenScale = 4 :: Int +gfxStart = 0x8000 :: Int +spritesStart = 0x9050 :: Int +spriteCount = 16 :: Int +inputStart = 0x9000 :: Int +inputMaxCount = 0x10 :: Int + +memorySize = 0x10000 + +data Reg = RegA + | RegB + | RegC + | RegX + | RegY + | RegZ + | RegI + | RegJ + | RegPC -- program counter + | RegSP -- stack pointer + | RegEx + deriving (Show, Bounded, Enum) + +data CpuState = CpuState { memory :: MV.IOVector Word16 + , regs :: MV.IOVector Word16 + } + +data Instr = Set + | Add + | Sub + | Mul + | Div + | Mod + | Shl + | Shr + | And + | Bor + | Xor + | Ife + | Ifn + | Ifg + | Ifb + | Jsr + | Dat + deriving (Show, Enum) + +data Value = ValueReg Reg -- register + | ValueAddrReg Reg -- [regiter] + | ValueAddrRegPlus Reg Word16 -- [next word + register] + | ValuePop + | ValuePeek + | ValuePush + | ValueSP + | ValuePC + | ValueO + | ValueAddr Word16 -- [next word] + | ValueLit Word16 + | ValueSymLit Word16 + deriving (Show) + +type InstrItem = (Instr, Value, Value) + +regCount = fromEnum (maxBound :: Reg) + 1 + +newCpu :: IO CpuState +newCpu = do + mem <- MV.new memorySize + regs <- MV.new regCount + return CpuState {memory = mem, regs = regs } + +readMemory :: CpuState -> Int -> IO Word16 +readMemory CpuState {memory = memory} = MV.read memory + +writeMemory :: CpuState -> Int -> Word16 -> IO () +writeMemory CpuState {memory = memory} = MV.write memory + +readRegister :: CpuState -> Reg -> IO Word16 +readRegister CpuState {regs = regs} reg = MV.read regs (fromEnum reg) + +writeRegister :: CpuState -> Reg -> Word16 -> IO () +writeRegister CpuState {regs = regs} reg = MV.write regs (fromEnum reg) + +incPC :: CpuState -> IO Word16 +incPC cpu = do + addr <- readRegister cpu RegPC + result <- readMemory cpu (fromIntegral addr) + writeRegister cpu RegPC (addr + 1) + return result + + +parseInstrParts :: Word16 -> (Word16, Word16, Word16) +parseInstrParts w = if oo == 0 then (aa + 0xf, bb, 0) else (oo, aa, bb) +-- a basic instruction format: bbbbbbaaaaaaoooo +-- a non-basic insruction format: aaaaaaoooooo0000 + where (oo, aa, bb) = (w .&. 0xf, (w `shiftR` 4) .&. 0x3f, (w `shiftR` 10) .&. 0x3f) + +withNextWord :: CpuState -> (Word16 -> a) -> IO a +withNextWord cpu f = do + w <- incPC cpu + return $ f w + +readValue :: CpuState -> Word16 -> IO Value +readValue cpu w = do + let reg w = toEnum $ fromIntegral w :: Reg + case w of + w | w <= 0x07 -> return $ ValueReg $ reg w + w | w <= 0x0f -> return $ ValueAddrReg $ reg $ w - 0x08 + w | w <= 0x17 -> withNextWord cpu $ ValueAddrRegPlus (reg $ w - 0x10) + 0x18 -> return ValuePop + 0x19 -> return ValuePeek + 0x1a -> return ValuePush + 0x1b -> return ValueSP + 0x1c -> return ValuePC + 0x1d -> return ValueO + 0x1e -> withNextWord cpu ValueAddr + 0x1f -> withNextWord cpu ValueLit + w | w <= 0x3f -> return $ ValueLit (w - 0x20) + _ -> fail "readValue: wrong value" + +readInstr :: CpuState -> IO InstrItem +readInstr cpu = do + w <- incPC cpu + let (oo, aa, bb) = parseInstrParts w + let instr = toEnum (fromIntegral $ oo - 1) :: Instr + a <- readValue cpu aa + b <- readValue cpu bb + return (instr, a, b) + +getValue :: CpuState -> Value -> IO Word16 +getValue cpu (ValueReg reg) = readRegister cpu reg +getValue cpu (ValueAddrReg reg) = do + w <- readRegister cpu reg + readMemory cpu (fromIntegral w) +getValue cpu (ValueAddrRegPlus reg next) = do + w <- readRegister cpu reg + let addr = w + next + readMemory cpu (fromIntegral addr) +getValue cpu ValuePop = do + sp <- readRegister cpu RegSP + writeRegister cpu RegSP (sp + 1) + readMemory cpu (fromIntegral sp) +getValue cpu ValuePeek = do + sp <- readRegister cpu RegSP + readMemory cpu (fromIntegral sp) +getValue cpu ValuePush = do + sp0 <- readRegister cpu RegSP + let sp = sp0 - 1 + writeRegister cpu RegSP sp + readMemory cpu (fromIntegral sp) +getValue cpu ValueSP = readRegister cpu RegSP +getValue cpu ValuePC = readRegister cpu RegPC +getValue cpu ValueO = readRegister cpu RegEx +getValue cpu (ValueAddr addr) = readMemory cpu (fromIntegral addr) +getValue _ (ValueLit lit) = return lit +getValue _ (ValueSymLit lit) = return lit + +setValue :: CpuState -> Value -> Word16 -> IO () +setValue cpu (ValueReg reg) v = writeRegister cpu reg v +setValue cpu (ValueAddrReg reg) v = do + w <- readRegister cpu reg + writeMemory cpu (fromIntegral w) v +setValue cpu (ValueAddrRegPlus reg next) v = do + w <- readRegister cpu reg + let addr = w + next + writeMemory cpu (fromIntegral addr) v +setValue cpu ValuePop v = do + sp <- readRegister cpu RegSP + writeRegister cpu RegSP (sp + 1) + writeMemory cpu (fromIntegral sp) v +setValue cpu ValuePeek v = do + sp <- readRegister cpu RegSP + writeMemory cpu (fromIntegral sp) v +setValue cpu ValuePush v = do + sp0 <- readRegister cpu RegSP + let sp = sp0 - 1 + writeRegister cpu RegSP sp + writeMemory cpu (fromIntegral sp) v +setValue cpu ValueSP v = writeRegister cpu RegSP v +setValue cpu ValuePC v = writeRegister cpu RegPC v +setValue cpu ValueO v = writeRegister cpu RegEx v +setValue cpu (ValueAddr addr) v = writeMemory cpu (fromIntegral addr) v +setValue _ (ValueLit _) _ = return () -- TODO: warn +setValue _ (ValueSymLit _) _ = return () -- TODO: warn + +evalInstr :: CpuState -> InstrItem -> IO () +evalInstr cpu (Set, dst, src) = do + w <- getValue cpu src + setValue cpu dst w +evalInstr cpu (Add, a, b) = evalArithInstr cpu a b op + where op a b = let res = a + b in (res, if res > 0xffff then 1 else 0) +evalInstr cpu (Sub, a, b) = evalArithInstr cpu a b op + where op a b = let res = a - b in (res, if res < 0 then 0xffff else 0) +evalInstr cpu (Mul, a, b) = evalArithInstr cpu a b op + where op a b = let res = a * b in (res, (res `shiftR` 16) .&. 0xffff) +evalInstr cpu (Div, a, b) = evalArithInstr cpu a b op + where op a b = if b == 0 then (0, 0) else (a`div`b, ((a `shiftL` 16) `div` b) .&. 0xffff) +evalInstr cpu (Mod, a, b) = evalArithInstr cpu a b op + where op a b = if b == 0 then (0, -1) else (a`mod`b, -1) +evalInstr cpu (Shl, a, b) = evalArithInstr cpu a b op + where op a b = let res = a `shiftL` b in (res, (res `shiftR` 16) .&. 0xffff) +evalInstr cpu (Shr, a, b) = evalArithInstr cpu a b op + where op a b = let res = a `shiftR` b in (res, ((res `shiftL` 16) `shiftR` b).&. 0xffff) +evalInstr cpu (And, a, b) = evalArithInstr cpu a b op + where op a b = if b == 0 then (0, -1) else (a .&. b, -1) +evalInstr cpu (Bor, a, b) = evalArithInstr cpu a b op + where op a b = if b == 0 then (0, -1) else (a .|. b, -1) +evalInstr cpu (Xor, a, b) = evalArithInstr cpu a b op + where op a b = if b == 0 then (0, -1) else (a `xor` b, -1) +evalInstr cpu (Ife, a, b) = evalIfInstr cpu a b (==) +evalInstr cpu (Ifn, a, b) = evalIfInstr cpu a b (/=) +evalInstr cpu (Ifg, a, b) = evalIfInstr cpu a b (>) +evalInstr cpu (Ifb, a, b) = evalIfInstr cpu a b (\a b -> (a .&. b) /= 0) +evalInstr cpu (Jsr, a, _) = do + evalInstr cpu (Set, ValuePush, ValuePC) + evalInstr cpu (Set, ValuePC, a) +evalInstr _ (Dat, _, _) = return () + +evalArithInstr :: CpuState -> Value -> Value -> (Int -> Int -> (Int, Int)) -> IO () +evalArithInstr cpu a b op = do + aa <- fromIntegral <$> getValue cpu a + bb <- fromIntegral <$> getValue cpu b + let (result, ex) = op aa bb + when (ex >= 0) $ writeRegister cpu RegEx $ fromIntegral ex + setValue cpu a $ fromIntegral result + +evalIfInstr :: CpuState -> Value -> Value -> (Word16 -> Word16 -> Bool) -> IO () +evalIfInstr cpu a b op = do + aa <- getValue cpu a + bb <- getValue cpu b + unless (op aa bb) $ void $ readInstr cpu + +writeMemoryData :: CpuState -> SV.Vector Word16 -> IO () +writeMemoryData cpu vec = SV.copy (MV.slice 0 (SV.length vec) $ memory cpu) vec + +runNextInstruction :: CpuState -> IO () +runNextInstruction cpu = do + instr <- readInstr cpu + evalInstr cpu instr diff --git a/src/Dcpu16/Dumper.hs b/src/Dcpu16/Dumper.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Dumper.hs @@ -0,0 +1,34 @@ +module Dcpu16.Dumper (dump) where + +import Dcpu16.Cpu +import Control.Monad +import Text.Printf + +dumpMemLine :: CpuState -> Int -> IO () +dumpMemLine cpu addr = do + putStr (printf "%04X:" addr) + forM_ [0..7] (\i -> readMemory cpu (addr + i) >>= putStr . printf " %04X") + putStrLn "" + +dumpMemPage :: CpuState -> Int -> IO () +dumpMemPage cpu base = forM_ [0,8..56] (\i -> dumpMemLine cpu (base + i)) + +dump :: CpuState -> IO () +dump cpu = do + pc <- readRegister cpu RegPC + sp <- readRegister cpu RegSP + a <- readRegister cpu RegA + b <- readRegister cpu RegB + c <- readRegister cpu RegC + x <- readRegister cpu RegX + y <- readRegister cpu RegY + z <- readRegister cpu RegZ + i <- readRegister cpu RegI + j <- readRegister cpu RegJ + putStrLn $ printf "PC: %04X SP: %04X" pc sp + putStrLn $ printf "A: %04X B: %04X C: %04X" a b c + putStrLn $ printf "X: %04X Y: %04X Z: %04X" x y z + putStrLn $ printf "I: %04X J: %04X" i j + putStrLn "\nMemory dump:" + dumpMemPage cpu 0 + putStrLn "" diff --git a/src/Dcpu16/Emulator.hs b/src/Dcpu16/Emulator.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Emulator.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module Dcpu16.Emulator + ( newEmulator + , loadBinaryProgram + , loadAsmProgram + , runEmulatorLoop + ) where + +import Dcpu16.Cpu +import Dcpu16.Video +import Dcpu16.Utils +import Dcpu16.Assembler + +import qualified Data.Vector.Storable as SV +import qualified Data.Vector.Storable.Mutable as MV +import qualified SDL +import qualified Data.ByteString as BS +import Data.IORef +import Control.Monad +import Control.Concurrent (threadDelay) + +data Emulator = Emulator { cpu :: CpuState } + +updateInput :: CpuState -> IORef Int -> [SDL.EventPayload] -> IO () +updateInput cpu pointerRef events = do + let codes = concatMap + (\case SDL.KeyboardEvent e | SDL.keyboardEventKeyMotion e == SDL.Pressed -> + case SDL.keysymKeycode (SDL.keyboardEventKeysym e) of + SDL.KeycodeLeft -> [1] + SDL.KeycodeRight -> [2] + SDL.KeycodeUp -> [3] + SDL.KeycodeDown -> [4] + _ -> [] + _ -> []) + events + + forM_ codes $ \code -> do + addr <- (+ inputStart) <$> readIORef pointerRef + old <- readMemory cpu addr + when (old == 0) $ do + writeMemory cpu addr $ fromIntegral code + modifyIORef' pointerRef (\x -> (x + 1) `mod` inputMaxCount) + +newEmulator :: IO Emulator +newEmulator = Emulator <$> newCpu + +loadBinaryProgram :: Emulator -> FilePath -> IO () +loadBinaryProgram Emulator {cpu = cpu} path = do + bs <- BS.readFile path + writeMemoryData cpu $ byteStringToVector bs + +loadAsmProgram :: Emulator -> FilePath -> IO () +loadAsmProgram Emulator {cpu = cpu} src = + compileFileToVec src >>= writeMemoryData cpu + +runEmulatorLoop :: Emulator -> IO () +runEmulatorLoop Emulator {cpu = cpu} = do + SDL.initialize [SDL.InitVideo] + + let windowSize = SDL.V2 (fromIntegral $ screenWidth * screenScale) (fromIntegral $ screenHeight * screenScale) + let windowConfig = SDL.defaultWindow { SDL.windowInitialSize = windowSize } + window <- SDL.createWindow "DCPU-16" windowConfig + SDL.showWindow window + + renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer + texture <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessStreaming $ + SDL.V2 (fromIntegral screenWidth) (fromIntegral screenHeight) + + screenBuf <- MV.new (screenWidth * screenHeight) + counterRef :: IORef Int <- newIORef 0 + keypointerRef :: IORef Int <- newIORef 0 + + let loop = do + events <- map SDL.eventPayload <$> SDL.pollEvents + let quit = SDL.QuitEvent `elem` events + + updateInput cpu keypointerRef events + runNextInstruction cpu + + counterValue <- readIORef counterRef + when (counterValue `mod` 1000 == 0) $ do + --putStrLn $ "Step " ++ show (counterValue + 1) + threadDelay 8000 + updateScreen cpu screenBuf + + screenBs <- vectorToByteString <$> SV.freeze screenBuf + SDL.updateTexture texture Nothing screenBs (fromIntegral $ screenWidth * 4) + + SDL.copy renderer texture Nothing Nothing + SDL.present renderer + + modifyIORef' counterRef (+1) + unless quit loop + loop + + SDL.destroyWindow window + SDL.quit + diff --git a/src/Dcpu16/Utils.hs b/src/Dcpu16/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Utils.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Dcpu16.Utils + ( module Data.Vector.Storable.ByteString + , writeVectorToFile + ) where + +import qualified Data.Vector.Storable as SV +import qualified Data.ByteString as BS +import qualified Foreign.Storable as FS +import Data.Vector.Storable.ByteString + +writeVectorToFile :: (FS.Storable a) => SV.Vector a -> FilePath -> IO () +writeVectorToFile vec filePath = BS.writeFile filePath bs + where bs = vectorToByteString vec diff --git a/src/Dcpu16/Video.hs b/src/Dcpu16/Video.hs new file mode 100644 --- /dev/null +++ b/src/Dcpu16/Video.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Dcpu16.Video where + +import Dcpu16.Cpu +import qualified Data.Vector.Storable.Mutable as MV +import qualified Data.Vector.Storable as SV +import Data.Bits +import Data.Word +import Control.Monad + +data SpriteMode = SpriteMode { width :: Int, height :: Int, bitsPerPixel :: Int } + +spriteModes :: [SpriteMode] +spriteModes = [ SpriteMode 8 8 4 + , SpriteMode 16 8 2 + , SpriteMode 8 16 2 + , SpriteMode 16 16 1] + +pallete :: SV.Vector Word32 +pallete = SV.fromList + [ 0x000000FF, 0x1B2632FF, 0x493C2BFF, 0x2F484EFF + , 0x005784FF, 0xBE2633FF, 0x44891AFF, 0xA46422FF + , 0x31A2F2FF, 0xE06F8BFF, 0xEB8931FF, 0x9D9D9DFF + , 0xA3CE27FF, 0xB2DCEFFF, 0xFFE26BFF, 0xFFFFFFFF] + +writeTexturePixel :: MV.IOVector Word32 -> Int -> Int -> Word16 -> IO () +writeTexturePixel screen x y pixel = do + let color = pallete SV.! fromIntegral pixel + MV.write screen (y * screenWidth + x) color + +drawBgPixel :: CpuState -> MV.IOVector Word32 -> Int -> Int -> IO () +drawBgPixel cpu screen x y = do + let addr = gfxStart + x `div` 3 + (y `div` 3) * (screenWidth `div` 3) + w <- readMemory cpu addr + let c1 = w `shiftR` 12 + let c2 = (w `shiftR` 8) .&. 0xf + let idx = x `mod` 3 + (y `mod` 3) * 3 + let b = w .&. (0x80 `shiftR` idx) + writeTexturePixel screen x y (if b /= 0 then c1 else c2) + +drawBg :: CpuState -> MV.IOVector Word32 -> IO () +drawBg cpu screen = do + let yx = [(y, x) | y <- [0..screenHeight-1], x <- [0..screenWidth-2]] + forM_ yx (\(y, x) -> drawBgPixel cpu screen x y) + +drawSprites :: CpuState -> MV.IOVector Word32 -> IO () +drawSprites cpu screen = forM_ [0..spriteCount-1] $ drawSprite cpu screen + +drawSprite :: CpuState -> MV.IOVector Word32 -> Int -> IO () +drawSprite cpu screen index = do + let addr = spritesStart + index * 2 + w1 :: Int <- fromIntegral <$> readMemory cpu addr + w2 :: Int <- fromIntegral <$> readMemory cpu (addr + 1) + let (sx, sy) = ((w1 `shiftR` 8) - 64, (w1 .&. 0xFF) - 64) + let (modeIndex, color) = (w2 `shiftR` 14, (w2 `shiftR` 10) .&. 0xf) + let dataAddr = gfxStart + (2 * (w2 .&. 0x3FF)) + let (SpriteMode width height bitsPerPixel) = spriteModes !! modeIndex + + forM_ [(y, x) | y <- [0..height-1], x <- [0..width-1]] $ \(y, x) -> do + let xy = y * width + x + let pixelAddr = dataAddr + xy * bitsPerPixel `div` 16 + w <- readMemory cpu pixelAddr + let offs = 16 - bitsPerPixel - (xy * bitsPerPixel) `mod` 16 + let col = (w `shiftR` offs) .&. ((1 `shiftL` bitsPerPixel) - 1) + + let transparent = if modeIndex == 3 then col == 0 else fromIntegral col == color + unless transparent $ do + let (rx, ry) = (sx + x, sy + y) + when (rx >= 0 && ry >= 0 && rx < screenWidth && ry < screenHeight) $ + writeTexturePixel screen rx ry col + +updateScreen :: CpuState -> MV.IOVector Word32 -> IO () +updateScreen cpu screen = do + drawBg cpu screen + drawSprites cpu screen diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,4 @@ + + +main :: IO () +main = putStrLn "Test suite not yet implemented"