Garmelon/mima-tools
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Reimplement all opcodes

Browse source
This commit is contained in:
Joscha 2019-11-07 13:37:26 +00:00
parent dd7c9d44a6
commit ef06f7b309
2 changed files with 89 additions and 64 deletions
Download patch file Download diff file Expand all files Collapse all files

140
src/Mima/State.hs
View file

@ -1,16 +1,19 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Mima.State module Mima.State
( MimaMemory (
, wordsToMemory -- * Memory
, memoryToWords MimaMemory
, memoryToText
, readAt , readAt
, writeAt , writeAt
-- ** Converting
, wordsToMemory
, memoryToWords
-- * State
, MimaState(..) , MimaState(..)
, initialState , initialState
, AbortReason(..) , AbortReason(..)
, ExecException(..)
, step , step
, run , run
, runN , runN
@ -18,7 +21,6 @@ module Mima.State
import Data.Bits import Data.Bits
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Mima.Instruction import Mima.Instruction
@ -30,8 +32,9 @@ newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord)
addressRange :: MimaMemory -> [MimaAddress] addressRange :: MimaMemory -> [MimaAddress]
addressRange (MimaMemory m) = addressRange (MimaMemory m) =
let maxAddr = fromMaybe minBound $ fst <$> Map.lookupMax m case fst <$> Map.lookupMax m of
in [minBound..maxAddr] Nothing -> []
Just maxAddr -> [minBound..maxAddr]
wordsToMemory :: [MimaWord] -> MimaMemory wordsToMemory :: [MimaWord] -> MimaMemory
wordsToMemory = MimaMemory wordsToMemory = MimaMemory
@ -42,6 +45,7 @@ wordsToMemory = MimaMemory
memoryToWords :: MimaMemory -> [MimaWord] memoryToWords :: MimaMemory -> [MimaWord]
memoryToWords mem = map (\addr -> readAt addr mem) $ addressRange mem memoryToWords mem = map (\addr -> readAt addr mem) $ addressRange mem
{-
addrWordLegend :: T.Text addrWordLegend :: T.Text
addrWordLegend = "SO: Small Opcode (bits 23-20) LO: Large Opcode (bits 19-16)\n" addrWordLegend = "SO: Small Opcode (bits 23-20) LO: Large Opcode (bits 19-16)\n"
<> "Addr (decimal) - Word ( decimal|SO,LO, Addr) - Instruction\n" <> "Addr (decimal) - Word ( decimal|SO,LO, Addr) - Instruction\n"
@ -68,6 +72,7 @@ memoryToText sparse mem@(MimaMemory m)
where where
addresses False = addressRange mem addresses False = addressRange mem
addresses True = Map.keys m addresses True = Map.keys m
-}
readAt :: MimaAddress -> MimaMemory -> MimaWord readAt :: MimaAddress -> MimaMemory -> MimaWord
readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m
@ -78,84 +83,91 @@ writeAt addr word (MimaMemory m)
| otherwise = MimaMemory $ Map.insert addr word m | otherwise = MimaMemory $ Map.insert addr word m
data MimaState = MimaState data MimaState = MimaState
{ msIp :: !MimaAddress { msIAR :: !MimaAddress
, msAcc :: !MimaWord , msACC :: !MimaWord
, msRA :: !MimaAddress
, msSP :: !MimaAddress
, msFP :: !MimaAddress
, msMemory :: !MimaMemory , msMemory :: !MimaMemory
} deriving (Show) } deriving (Show)
-- | A possible initial MiMa state, where every register is
-- zeroed. Thus, execution starts at address 0x00000.
initialState :: MimaMemory -> MimaState initialState :: MimaMemory -> MimaState
initialState mem = MimaState initialState mem = MimaState
{ msIp = minBound { msIAR = zeroBits
, msAcc = zeroBits , msACC = zeroBits
, msRA = zeroBits
, msSP = zeroBits
, msFP = zeroBits
, msMemory = mem , msMemory = mem
} }
data AbortReason = Halted | InvalidInstruction T.Text | InvalidNextIpAddress data AbortReason = Halted | InvalidInstruction T.Text | InvalidNextIarAddress
deriving (Show) deriving (Show)
instance ToText AbortReason where instance ToText AbortReason where
toText Halted = "Halted" toText Halted = "Halted"
toText (InvalidInstruction t) = "Invalid instruction: " <> t toText (InvalidInstruction t) = "Invalid instruction: " <> t
toText InvalidNextIpAddress = "Invalid next IP address" toText InvalidNextIarAddress = "Can't increment IAR: Invalid next address"
data ExecException = ExecException MimaAddress MimaWord AbortReason incrementIAR :: MimaState -> Either AbortReason MimaState
deriving (Show) incrementIAR ms =
let addr = msIAR ms
instance ToText ExecException where
toText (ExecException addr word reason) =
"Exception at " <> addrToHexDec addr <> " with word " <> wordToHexDec word <> ": " <> toText reason
incrementIp :: MimaState -> Either ExecException MimaState
incrementIp ms =
let addr = msIp ms
in if addr >= maxBound in if addr >= maxBound
then Left $ ExecException addr (readAt addr $ msMemory ms) InvalidNextIpAddress then Left InvalidNextIarAddress
else pure ms{msIp = succ addr} else Right ms{msIAR = succ addr}
wordToInstruction' :: MimaAddress -> MimaWord -> Either ExecException Instruction wordToInstruction' :: MimaWord -> Either AbortReason Instruction
wordToInstruction' addr word = wordToInstruction' word =
case wordToInstruction word of case wordToInstruction word of
Right instruction -> pure instruction Right instruction -> Right instruction
Left errorMsg -> Left $ ExecException addr word $ InvalidInstruction errorMsg Left errorMsg -> Left $ InvalidInstruction errorMsg
step :: MimaState -> Either ExecException MimaState step :: MimaState -> Either AbortReason MimaState
step ms = do step ms = do
let addr = msIp ms let word = readAt (msIAR ms) (msMemory ms)
word = readAt addr (msMemory ms) ms' <- incrementIAR ms
instruction <- wordToInstruction' addr word instruction <- wordToInstruction' word
case instruction of case instruction of
(SmallInstruction oc instrAddr) -> executeSmallOpcode oc instrAddr ms (SmallInstruction so lv) -> pure $ doSmallOpcode so lv ms'
(LargeInstruction oc) -> executeLargeOpcode oc ms (LargeInstruction lo sv) -> doLargeOpcode lo sv ms'
executeSmallOpcode :: SmallOpcode -> MimaAddress -> MimaState -> Either ExecException MimaState doSmallOpcode :: SmallOpcode -> LargeValue -> MimaState -> MimaState
executeSmallOpcode LDC addr ms = incrementIp ms{msAcc = addrToWord addr} doSmallOpcode LDC lv ms@MimaState{..} = ms{msACC = largeValueToWord lv}
executeSmallOpcode LDV addr ms = incrementIp ms{msAcc = readAt addr (msMemory ms)} doSmallOpcode LDV addr ms@MimaState{..} = ms{msACC = readAt addr msMemory}
executeSmallOpcode STV addr ms = incrementIp ms{msMemory = writeAt addr (msAcc ms) (msMemory ms)} doSmallOpcode STV addr ms@MimaState{..} = ms{msMemory = writeAt addr msACC msMemory}
executeSmallOpcode ADD addr ms = incrementIp ms{msAcc = addWords (msAcc ms) (readAt addr $ msMemory ms)} doSmallOpcode ADD addr ms@MimaState{..} = ms{msACC = addWords msACC $ readAt addr msMemory}
executeSmallOpcode AND addr ms = incrementIp ms{msAcc = msAcc ms .&. readAt addr (msMemory ms)} doSmallOpcode AND addr ms@MimaState{..} = ms{msACC = msACC .&. readAt addr msMemory}
executeSmallOpcode OR addr ms = incrementIp ms{msAcc = msAcc ms .|. readAt addr (msMemory ms)} doSmallOpcode OR addr ms@MimaState{..} = ms{msACC = msACC .|. readAt addr msMemory}
executeSmallOpcode XOR addr ms = incrementIp ms{msAcc = msAcc ms `xor` readAt addr (msMemory ms)} doSmallOpcode XOR addr ms@MimaState{..} = ms{msACC = msACC `xor` readAt addr msMemory}
executeSmallOpcode EQL addr ms = incrementIp ms{msAcc = boolToWord $ msAcc ms == readAt addr (msMemory ms)} doSmallOpcode EQL addr ms@MimaState{..} = ms{msACC = boolToWord $ msACC == readAt addr msMemory}
executeSmallOpcode JMP addr ms = pure ms{msIp = addr} doSmallOpcode JMP addr ms@MimaState{..} = ms{msIAR = addr}
executeSmallOpcode JMN addr ms = if topBit (msAcc ms) then pure ms{msIp = addr} else incrementIp ms doSmallOpcode JMN addr ms@MimaState{..} = if topBit msACC then ms{msIAR = addr} else ms
executeSmallOpcode STIV addr ms = doSmallOpcode LDIV addr ms@MimaState{..} =
let mem = msMemory ms let indirAddr = getAddress $ readAt addr msMemory
indirAddr = address $ readAt addr mem in ms{msACC = readAt indirAddr msMemory}
in incrementIp ms{msMemory = writeAt indirAddr (msAcc ms) mem} doSmallOpcode STIV addr ms@MimaState{..} =
executeSmallOpcode LDIV addr ms = let indirAddr = getAddress $ readAt addr msMemory
let mem = msMemory ms in ms{msMemory = writeAt indirAddr msACC msMemory}
indirAddr = address $ readAt addr mem doSmallOpcode CALL addr ms@MimaState{..} = ms{msRA = msIAR, msIAR = addr}
in incrementIp ms{msAcc = readAt indirAddr mem} doSmallOpcode LDVR addr ms@MimaState{..} = ms{msACC = readAt (addLargeValues msSP addr) msMemory}
doSmallOpcode STVR addr ms@MimaState{..} = ms{msMemory = writeAt (addLargeValues msSP addr) msACC msMemory}
executeLargeOpcode :: LargeOpcode -> MimaState -> Either ExecException MimaState doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Either AbortReason MimaState
executeLargeOpcode HALT ms = doLargeOpcode HALT _ _ = Left Halted
let addr = msIp ms doLargeOpcode NOT _ ms@MimaState{..} = pure ms{msACC = complement msACC}
word = readAt addr (msMemory ms) doLargeOpcode RAR _ ms@MimaState{..} = pure ms{msACC = rotateR msACC 1}
in Left $ ExecException addr word Halted doLargeOpcode RET _ ms@MimaState{..} = pure ms{msIAR = msRA}
executeLargeOpcode NOT ms = incrementIp ms{msAcc = complement (msAcc ms)} doLargeOpcode LDRA _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msRA}
executeLargeOpcode RAR ms = incrementIp ms{msAcc = rotateR (msAcc ms) 1} doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRA = getAddress msACC}
doLargeOpcode LDSP _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msSP}
doLargeOpcode STSP _ ms@MimaState{..} = pure ms{msSP = getAddress msACC}
doLargeOpcode LDFP _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msFP}
doLargeOpcode STFP _ ms@MimaState{..} = pure ms{msFP = getAddress msACC}
doLargeOpcode ADC sv ms@MimaState{..} = pure ms{msACC = addWords msACC $ signedSmallValueToWord sv}
run :: MimaState -> (MimaState, ExecException, Integer) run :: MimaState -> (MimaState, AbortReason, Integer)
run ms = helper 0 ms run ms = helper 0 ms
where where
helper completed s = helper completed s =
@ -163,7 +175,7 @@ run ms = helper 0 ms
Left e -> (s, e, completed) Left e -> (s, e, completed)
Right s' -> helper (completed + 1) s' Right s' -> helper (completed + 1) s'
runN :: Integer -> MimaState -> (MimaState, Maybe ExecException, Integer) runN :: Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
runN n ms = helper 0 ms runN n ms = helper 0 ms
where where
helper completed s = helper completed s =

13
src/Mima/Word.hs
View file

@ -31,6 +31,8 @@ module Mima.Word
, bytesToLargeValue , bytesToLargeValue
, largeValueToBytes , largeValueToBytes
, largeValueToWord , largeValueToWord
-- ** Operations
, addLargeValues
-- * 16-bit value -- * 16-bit value
, SmallValue , SmallValue
-- ** Formatting -- ** Formatting
@ -42,6 +44,7 @@ module Mima.Word
) where ) where
import Data.Bits import Data.Bits
import Data.Function
import qualified Data.Text as T import qualified Data.Text as T
import Data.Word import Data.Word
@ -76,6 +79,13 @@ instance (Word32Based t) => Word32Based (WB t) where
instance (Word32Based t) => Eq (WB t) where instance (Word32Based t) => Eq (WB t) where
w1 == w2 = toWord32 (unWB w1) == toWord32 (unWB w2) w1 == w2 = toWord32 (unWB w1) == toWord32 (unWB w2)
instance (Word32Based t) => Ord (WB t) where
compare = compare `on` toWord32
(<) = (<) `on` toWord32
(<=) = (<=) `on` toWord32
(>) = (>) `on` toWord32
(>=) = (>=) `on` toWord32
instance (Word32Based t) => Bits (WB t) where instance (Word32Based t) => Bits (WB t) where
t1 .&. t2 = fromWord32 $ toWord32 t1 .&. toWord32 t2 t1 .&. t2 = fromWord32 $ toWord32 t1 .&. toWord32 t2
t1 .|. t2 = fromWord32 $ toWord32 t1 .|. toWord32 t2 t1 .|. t2 = fromWord32 $ toWord32 t1 .|. toWord32 t2
@ -215,6 +225,9 @@ largeValueToBytes = wordToBytes . largeValueToWord
largeValueToWord :: LargeValue -> MimaWord largeValueToWord :: LargeValue -> MimaWord
largeValueToWord = fromWord32 . toWord32 largeValueToWord = fromWord32 . toWord32
addLargeValues :: LargeValue -> LargeValue -> LargeValue
addLargeValues lv1 lv2 = getLargeValue $ addWords (largeValueToWord lv1) (largeValueToWord lv2)
type SmallValue = WB SmallValue_ type SmallValue = WB SmallValue_
newtype SmallValue_ = SmallValue_ Word32 newtype SmallValue_ = SmallValue_ Word32