Implementation of version 1.1 of http://0x10c.com/doc/dcpu-16.txt

DCPU16.hs

-- Implementation of version 1.1 of http://0x10c.com/doc/dcpu-16.txt.
-- This work is public domain.
module DCPU16 where

import Control.Monad(foldM)
import Data.Array.IO(IOArray)
import Data.Array.MArray(newListArray,readArray,writeArray)
import Data.Bits((.&.),(.|.),shiftL,shiftR,xor)
import Data.Ix(Ix)
import Data.Word(Word16,Word32)

data Register = A | B | C | X | Y | Z | I | J | PC | SP | O
    deriving (Bounded,Eq,Ix,Ord)

-- For example, m could be IO, Control.Monad.ST.ST,
-- or Control.Concurrent.STM.STM.
-- Memory-mapped I/O would be implemented by readRAM and writeRAM.
data DCPU m = DCPU {
    readRAM :: Word16 -> m Word16,
    writeRAM :: Word16 -> Word16 -> m (),
    readRegister :: Register -> m Word16,
    writeRegister :: Register -> Word16 -> m ()
    }

-- Execute one instruction and return the number of cycles used.
execute :: Monad m => DCPU m -> m Int
execute dcpu = do
    insn <- nextWord dcpu
    if insn .&. 0xf /= 0
      then do
        a <- arg dcpu ((insn `shiftR` 4) .&. 0x3f)
        b <- arg dcpu ((insn `shiftR` 10) .&. 0x3f)
        basic dcpu (insn .&. 0xf) a b (insnSize insn)
      else do
        a <- arg dcpu ((insn `shiftR` 10) .&. 0x3f)
        nonBasic dcpu ((insn `shiftR` 4) .&. 0x3f) a (insnSize insn)

basic :: Monad m => DCPU m -> Word16 -> Operand m -> Operand m -> Int -> m Int
basic dcpu opcode a b cycles
  | opcode == 0x01 = fst b >>= snd a >> return cycles
  | opcode == 0x02 = overflow (+) (\ x y -> if x + y >= max x y then 0 else 1) (cycles + 1)
  | opcode == 0x03 = overflow (-) (\ x y -> if x >= y then 0 else -1) (cycles + 1)
  | opcode == 0x04 = overflow (*) (\ x y -> fromIntegral ((fromIntegral x * fromIntegral y :: Word32) `shiftR` 16)) (cycles + 1)
  | opcode == 0x05 = overflow div (\ x y -> fromIntegral ((fromIntegral	x `shiftL` 16) `div` fromIntegral y :: Word32)) (cycles + 2)
  | opcode == 0x06 = binop (\ x y -> if y == 0 then 0 else x `mod` y) (cycles + 2)
  | opcode == 0x07 = overflow (\ x y -> x `shiftL` fromIntegral y) (\ x y -> x `shiftR` (16 - fromIntegral y)) (cycles + 1)
  | opcode == 0x08 = overflow (\ x y -> x `shiftR` fromIntegral y) (\ x y -> x `shiftL` (16 - fromIntegral y)) (cycles + 1)
  | opcode == 0x09 = binop (.&.) cycles
  | opcode == 0x0a = binop (.|.) cycles
  | opcode == 0x0b = binop xor cycles
  | opcode == 0x0c = branch (==) False
  | opcode == 0x0d = branch (==) True
  | opcode == 0x0e = branch (>) False
  | opcode == 0x0f = branch (.&.) 0
  | otherwise = error ("Unknown basic opcode " ++ show opcode)
  where
    binop op cycles = do
        worda <- fst a
        wordb <- fst b
        snd a (worda `op` wordb)
        return cycles
    overflow op overflowop cycles = do
        worda <- fst a
        wordb <- fst b
        snd a (worda `op` wordb)
        writeRegister dcpu O (worda `overflowop` wordb)
        return cycles
    branch op skip = do
        worda <- fst a
        wordb <- fst b
        if worda `op` wordb == skip
          then do
            pc <- readRegister dcpu PC
            insn <- readRAM dcpu pc
            writeRegister dcpu PC (pc + fromIntegral (insnSize insn))
            return (cycles + 2)
          else return (cycles + 1)

nonBasic :: Monad m => DCPU m -> Word16 -> Operand m -> Int -> m Int
nonBasic dcpu opcode a cycles
  | opcode == 0x01 = do
        word <- fst a
        pc <- readRegister dcpu PC
        sp <- readRegister dcpu SP
        writeRegister dcpu SP (sp - 1)
        writeRAM dcpu (sp - 1) pc
        writeRegister dcpu PC word
        return (cycles + 1)
  | otherwise = error ("Unknown non-basic opcode " ++ show opcode)

register :: Word16 -> Register
register 0x0 = A
register 0x1 = B
register 0x2 = C
register 0x3 = X
register 0x4 = Y
register 0x5 = Z
register 0x6 = I
register 0x7 = J
register r = error ("Unknown register " ++ show r)

nextWord :: Monad m => DCPU m -> m Word16
nextWord dcpu = do
    pc <- readRegister dcpu PC
    writeRegister dcpu PC (pc + 1)
    readRAM dcpu pc

type Operand m = (m Word16,Word16 -> m ())

arg :: Monad m => DCPU m -> Word16 -> m (Operand m)
arg dcpu operand
  | operand < 0x08 = accessRegister (register operand)
  | operand < 0x10 = do
        r <- readRegister dcpu (register (operand .&. 0x07))
        accessRAM r
  | operand < 0x18 = do
        index <- readRegister dcpu (register (operand .&. 0x07))
        base <- nextWord dcpu
        accessRAM (index + base)
  | operand == 0x18 = do
        sp <- readRegister dcpu SP
        writeRegister dcpu SP (sp + 1)
        accessRAM sp
  | operand == 0x19 = do
        sp <- readRegister dcpu SP
        accessRAM sp
  | operand == 0x1a = do
        sp <- readRegister dcpu SP
        writeRegister dcpu SP (sp - 1)
        accessRAM (sp - 1)
  | operand == 0x1b = accessRegister SP
  | operand == 0x1c = accessRegister PC
  | operand == 0x1d = accessRegister O
  | operand == 0x1e = do
        word <- nextWord dcpu
        accessRAM word
  | operand == 0x1f = do
        word <- nextWord dcpu
        return (return word, const (return ()))
  | otherwise = return (return (operand .&. 0x1f), const (return ()))
  where
    accessRegister register = do
        word <- readRegister dcpu register
        return (return word, writeRegister dcpu register)
    accessRAM location =
        return (readRAM dcpu location, writeRAM dcpu location)

insnSize :: Word16 -> Int
insnSize insn =
    if insn .&. 0xf /= 0
      then 1 + argCycles ((insn `shiftR` 4) .&. 0x3f) + argCycles ((insn `shiftR` 10) .&. 0x3f)
      else 1 + argCycles ((insn `shiftR` 10) .&. 0x3f)

argCycles :: Word16 -> Int
argCycles operand
  | operand >= 0x10 && operand <= 0x17 = 1
  | operand == 0x1e || operand == 0x1f = 1
  | otherwise = 0

makeDCPU :: [Word16] -> IO (DCPU IO)
makeDCPU words = do
    ram <- newListArray (minBound,maxBound) (words ++ repeat 0)
    registers <- newListArray (minBound,maxBound) (repeat 0)
    return DCPU {
        readRAM = readArray (ram :: IOArray Word16 Word16),
        writeRAM = writeArray ram,
        readRegister = readArray (registers :: IOArray Register Word16),
        writeRegister = writeArray registers
        }

test :: IO ()
test = do
    dcpu <- makeDCPU [
        0x7c01, 0x0030, 0x7de1, 0x1000, 0x0020, 0x7803, 0x1000, 0xc00d,
        0x7dc1, 0x001a, 0xa861, 0x7c01, 0x2000, 0x2161, 0x2000, 0x8463,
        0x806d, 0x7dc1, 0x000d, 0x9031, 0x7c10, 0x0018, 0x7dc1, 0x001a,
        0x9037, 0x61c1, 0x7dc1, 0x001a, 0x0000, 0x0000, 0x0000, 0x0000]
    cycles <- foldM (\ cycles _ -> fmap (cycles +) (execute dcpu)) 0 [1..50]
    pc <- readRegister dcpu PC
    x <- readRegister dcpu X
    putStrLn ("PC=" ++ show pc ++ " X=" ++ show x ++ " cycles=" ++ show cycles)