Skip to content

Commit

Permalink
Use FetchM for instruction fetching
Browse files Browse the repository at this point in the history
  • Loading branch information
@gergoerdi
gergoerdi committed May 28, 2019
1 parent cd717df commit 9ca30e4
Show file tree
Hide file tree
Showing 3 changed files with 119 additions and 66 deletions.
55 changes: 26 additions & 29 deletions src-clash/CHIP8/CPU.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,14 +18,16 @@ import Data.Maybe (fromMaybe)
import Debug.Trace
import Text.Printf

import FetchM

data DrawPhase
= DrawRead
| DrawWrite
deriving (Generic, Undefined)

data Phase
= Init
| Fetch1
| Fetching (Buffer 2 Word8)
| Exec
| StoreReg Reg
| LoadReg Reg
Expand All @@ -50,8 +52,7 @@ data CPUIn = CPUIn
}

data CPUState = CPUState
{ opHi, opLo :: Word8
, pc, ptr :: Addr
{ pc, ptr :: Addr
, registers :: Vec 16 Word8
, stack :: Vec 24 Addr
, sp :: Index 24
Expand All @@ -63,9 +64,7 @@ data CPUState = CPUState

initState :: CPUState
initState = CPUState
{ opHi = 0x00
, opLo = 0x00
, pc = 0x200
{ pc = 0x200
, ptr = 0x000
, registers = pure 0
, stack = pure 0
Expand Down Expand Up @@ -98,31 +97,30 @@ cpu = do
when cpuInVBlank $ modify $ \s -> s{ timer = fromMaybe 0 $ predIdx timer }

case phase of
Init -> goto Fetch1
Fetch1 -> do
modify $ \s -> s
{ opHi = cpuInMem
, pc = succ pc
}
goto Exec
Exec -> do
modify $ \s -> s
{ opLo = cpuInMem
, pc = trace (printf "PC = %04x" (fromIntegral pc :: Word16)) $ succ pc
}
goto Fetch1
exec
Init -> goto $ Fetching def
Fetching buf -> do
buf' <- remember buf <$> do
modify $ \s -> s{ pc = trace (printf "PC = %04x" (fromIntegral pc :: Word16)) $ succ pc }
return cpuInMem
instr_ <- runFetchM buf' $ fetchInstr fetch
instr <- case instr_ of
Left Underrun -> goto (Fetching buf') >> abort
Left Overrun -> error "Overrun"
Right instr -> return instr
goto $ Fetching def
exec instr

StoreReg r -> case predIdx r of
Nothing -> goto Fetch1
Nothing -> goto $ Fetching def
Just r' -> storeReg r'
LoadReg r -> loadReg r
ClearFB xy -> clearFB xy
Draw dp xy row col -> draw dp xy row col
WaitKeyPress reg -> for_ cpuInKeyEvent $ \(pressed, key) -> when pressed $ do
setReg reg $ fromIntegral key
goto Fetch1
goto $ Fetching def
WriteBCD x i -> case succIdx i of
Nothing -> goto Fetch1
Nothing -> goto $ Fetching def
Just i' -> do
let addr = ptr + fromIntegral i'
writeMem addr $ toBCDRom x !! i'
Expand All @@ -132,7 +130,7 @@ cpu = do

clearFB xy = do
writeFB xy low
goto $ maybe Fetch1 ClearFB $ succXY xy
goto $ maybe (Fetching def) ClearFB $ succXY xy

setReg reg val = modify $ \s -> s{ registers = replace reg val (registers s) }
getReg reg = gets $ (!! reg) . registers
Expand All @@ -147,7 +145,7 @@ cpu = do
val <- cpuInMem <$> input
setReg reg val
case predIdx reg of
Nothing -> goto Fetch1
Nothing -> goto $ Fetching def
Just reg' -> do
ptr <- gets ptr
readMem (ptr + fromIntegral reg')
Expand Down Expand Up @@ -175,10 +173,9 @@ cpu = do
pc <- gets pc
jump $ pc + 2

exec = do
exec instr = do
CPUIn{..} <- input
CPUState{opHi, opLo} <- get
case traceShowId $ decode opHi opLo of
case traceShowId instr of
ClearScreen -> clearFB minBound
Ret -> do
popPC
Expand Down Expand Up @@ -263,7 +260,7 @@ cpu = do
let next = msum [ (row,) <$> predIdx col
, (,maxBound) <$> predIdx row
]
goto $ maybe Fetch1 (uncurry $ Draw DrawRead (x, y)) next
goto $ maybe (Fetching def) (uncurry $ Draw DrawRead (x, y)) next
draw DrawRead (x, y) row col = do
ptr <- gets ptr
readFB (x + fromIntegral col, y + fromIntegral row)
Expand Down
76 changes: 39 additions & 37 deletions src-clash/CHIP8/Opcode.hs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
module CHIP8.Opcode
( Fun(..), Op(..)
, decode
, fetchInstr
) where

import Clash.Prelude
Expand Down Expand Up @@ -46,43 +46,45 @@ data Op = ClearScreen
| LoadRegs Reg
deriving (Show, Generic, Undefined)

decode :: Word8 -> Word8 -> Op
decode hi lo = case codes of
(0x0, 0x0, 0xe, 0x0) -> ClearScreen
(0x0, 0x0, 0xe, 0xe) -> Ret
(0x0, _, _, _) -> Sys addr
(0x1, _, _, _) -> Jump addr
(0x2, _, _, _) -> Call addr
(0x3, x, _, _) -> SkipEqImm (reg x) imm True
(0x4, x, _, _) -> SkipEqImm (reg x) imm False
(0x5, x, y, 0x0) -> SkipEqReg (reg x) (reg y) True
(0x6, x, _, _) -> PutImm (reg x) imm
(0x7, x, _, _) -> AddImm (reg x) imm
(0x8, x, y, fun) -> Move (reg x) (reg y) (decodeFun fun)
(0x9, x, y, 0x0) -> SkipEqReg (reg x) (reg y) False
(0xa, _, _, _) -> SetPtr addr
(0xb, _, _, _) -> JumpPlusR0 addr
(0xc, x, _, _) -> Randomize (reg x) imm
(0xd, x, y, n) -> DrawSprite (reg x) (reg y) n
(0xe, x, 0x9, 0xe) -> SkipKey (reg x) True
(0xe, x, 0xa, 0x1) -> SkipKey (reg x) False
(0xf, x, 0x0, 0x7) -> GetTimer (reg x)
(0xf, x, 0x0, 0xa) -> WaitKey (reg x)
(0xf, x, 0x1, 0x5) -> SetTimer (reg x)
(0xf, x, 0x1, 0x8) -> SetSound (reg x)
(0xf, x, 0x1, 0xe) -> AddPtr (reg x)
(0xf, x, 0x2, 0x9) -> LoadFont (reg x)
(0xf, x, 0x3, 0x3) -> StoreBCD (reg x)
(0xf, x, 0x5, 0x5) -> StoreRegs (reg x)
(0xf, x, 0x6, 0x5) -> LoadRegs (reg x)
_ -> errorX $ "Unknown opcode: " -- <> unwords [show a1, show a2, show a3, show a4]
fetchInstr :: (Monad m) => m Word8 -> m Op
fetchInstr fetch = do
hi <- fetch
lo <- fetch
let (a1, a2) = nybbles hi
(a3, a4) = nybbles lo
codes = (a1, a2, a3, a4)
addr = toAddr a2 a3 a4
imm = lo
return $ case codes of
(0x0, 0x0, 0xe, 0x0) -> ClearScreen
(0x0, 0x0, 0xe, 0xe) -> Ret
(0x0, _, _, _) -> Sys addr
(0x1, _, _, _) -> Jump addr
(0x2, _, _, _) -> Call addr
(0x3, x, _, _) -> SkipEqImm (reg x) imm True
(0x4, x, _, _) -> SkipEqImm (reg x) imm False
(0x5, x, y, 0x0) -> SkipEqReg (reg x) (reg y) True
(0x6, x, _, _) -> PutImm (reg x) imm
(0x7, x, _, _) -> AddImm (reg x) imm
(0x8, x, y, fun) -> Move (reg x) (reg y) (decodeFun fun)
(0x9, x, y, 0x0) -> SkipEqReg (reg x) (reg y) False
(0xa, _, _, _) -> SetPtr addr
(0xb, _, _, _) -> JumpPlusR0 addr
(0xc, x, _, _) -> Randomize (reg x) imm
(0xd, x, y, n) -> DrawSprite (reg x) (reg y) n
(0xe, x, 0x9, 0xe) -> SkipKey (reg x) True
(0xe, x, 0xa, 0x1) -> SkipKey (reg x) False
(0xf, x, 0x0, 0x7) -> GetTimer (reg x)
(0xf, x, 0x0, 0xa) -> WaitKey (reg x)
(0xf, x, 0x1, 0x5) -> SetTimer (reg x)
(0xf, x, 0x1, 0x8) -> SetSound (reg x)
(0xf, x, 0x1, 0xe) -> AddPtr (reg x)
(0xf, x, 0x2, 0x9) -> LoadFont (reg x)
(0xf, x, 0x3, 0x3) -> StoreBCD (reg x)
(0xf, x, 0x5, 0x5) -> StoreRegs (reg x)
(0xf, x, 0x6, 0x5) -> LoadRegs (reg x)
_ -> errorX $ "Unknown opcode: " -- <> unwords [show a1, show a2, show a3, show a4]
where
(a1, a2) = nybbles hi
(a3, a4) = nybbles lo
codes = (a1, a2, a3, a4)
addr = toAddr a2 a3 a4
imm = lo

reg = bitCoerce

decodeFun :: Nybble -> Fun
Expand Down
54 changes: 54 additions & 0 deletions src-clash/FetchM.hs
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,54 @@
{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-}
module FetchM where

import Prelude ()
import Clash.Prelude hiding (lift)

import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Except
import Data.Default

data Failure
= Underrun
| Overrun
deriving Show

data Buffer n dat = Buffer
{ bufferContents :: Vec n dat
, bufferLast :: Maybe (Index n)
}
deriving (Show, Generic, Undefined)

instance (KnownNat n, Default dat) => Default (Buffer n dat) where
def = Buffer (pure def) Nothing

remember :: (KnownNat n) => Buffer n dat -> dat -> Buffer n dat
remember Buffer{..} x = Buffer
{ bufferContents = replace bufferLast' x bufferContents
, bufferLast = Just bufferLast'
}
where
bufferLast' = maybe minBound (+ 1) bufferLast

newtype FetchM n dat m a = FetchM{ unFetchM :: ReaderT (Buffer n dat) (StateT (Maybe (Index n)) (ExceptT Failure m)) a }
deriving newtype (Functor, Applicative, Monad)

runFetchM :: (Monad m, KnownNat n) => Buffer n dat -> FetchM n dat m a -> m (Either Failure a)
runFetchM buf act = runExceptT $ evalStateT (runReaderT (unFetchM act) buf) Nothing

fetch :: (Monad m, KnownNat n) => FetchM n dat m dat
fetch = do
Buffer{..} <- FetchM ask
case bufferLast of
Nothing -> underrun
Just bufferLast -> do
idx <- FetchM get
when (maybe False (== maxBound) idx) overrun
when (maybe False (>= bufferLast) idx) underrun
let idx' = maybe minBound (+ 1) idx
FetchM $ put $ Just idx'
return $ bufferContents !! idx'
where
overrun = FetchM . lift . lift . throwE $ Overrun
underrun = FetchM . lift . lift . throwE $ Underrun

0 comments on commit 9ca30e4

Please sign in to comment.