From 2843cfd462f25403b417063429945fb3a4783c4d Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 6 Nov 2019 09:32:49 +0000 Subject: [PATCH] Execute a MiMa state --- package.yaml | 4 +-- src/Mima/Instruction.hs | 14 ++++---- src/Mima/State.hs | 74 +++++++++++++++++++++++++++++++++++++++ src/Mima/Word.hs | 76 +++++++++++++++++++++++++++++++++++++++-- 4 files changed, 157 insertions(+), 11 deletions(-) create mode 100644 src/Mima/State.hs diff --git a/package.yaml b/package.yaml index 6a6df78..2efbe3e 100644 --- a/package.yaml +++ b/package.yaml @@ -19,8 +19,8 @@ extra-source-files: description: Please see the README on GitHub at dependencies: -- base >= 4.7 && < 5 -- text >= 1.2.3 && < 1.3 +- base >= 4.7 && < 5 +- text >= 1.2.3 && < 1.3 - containers >= 0.6.0 && < 0.7 # - array >= 0.5.3 && < 0.6 # - binary >= 0.8.6 && < 0.9 diff --git a/src/Mima/Instruction.hs b/src/Mima/Instruction.hs index 768f7b6..cee9338 100644 --- a/src/Mima/Instruction.hs +++ b/src/Mima/Instruction.hs @@ -4,7 +4,7 @@ module Mima.Instruction ( SmallOpcode(..) , LargeOpcode(..) , Instruction(..) - , instructionFromWord + , wordToInstruction ) where import Data.Bits @@ -57,8 +57,8 @@ largeOpcodeMap :: Map.Map Word32 LargeOpcode largeOpcodeMap = Map.fromList [(getLargeOpcode oc, oc) | oc <- allLargeOpcodes] data Instruction - = SmallInstruction SmallOpcode MimaAddress - | LargeInstruction LargeOpcode + = SmallInstruction !SmallOpcode !MimaAddress + | LargeInstruction !LargeOpcode deriving (Show, Eq) instance ToText Instruction where @@ -74,10 +74,10 @@ lowerOpcode mw = shiftR (toWord32 mw) 16 .&. 0xF address :: MimaWord -> MimaAddress address = fromWord32 . toWord32 -- no shifting required -instructionFromWord :: MimaWord -> Either T.Text Instruction -instructionFromWord mw = if upperOpcode mw == 0xF - then parseLargeInstruction mw - else parseSmallInstruction mw +wordToInstruction :: MimaWord -> Either T.Text Instruction +wordToInstruction mw = if upperOpcode mw == 0xF + then parseLargeInstruction mw + else parseSmallInstruction mw parseSmallInstruction :: MimaWord -> Either T.Text Instruction parseSmallInstruction mw = do diff --git a/src/Mima/State.hs b/src/Mima/State.hs new file mode 100644 index 0000000..9123282 --- /dev/null +++ b/src/Mima/State.hs @@ -0,0 +1,74 @@ +module Mima.State + ( MimaMemory + , readAt + , writeAt + , MimaState(..) + ) where + +import Data.Bits +import qualified Data.Map as Map +import qualified Data.Text as T + +import Mima.Instruction +import Mima.Word + +newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord) + +readAt :: MimaAddress -> MimaMemory -> MimaWord +readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m + +writeAt :: MimaAddress -> MimaWord -> MimaMemory -> MimaMemory +writeAt addr word (MimaMemory m) + | word == zeroBits = MimaMemory $ Map.delete addr m + | otherwise = MimaMemory $ Map.insert addr word m + +data MimaState = MimaState + { msIp :: !MimaAddress + , msAcc :: !MimaWord + , msMemory :: !MimaMemory + } + +data AbortReason = Halted | InvalidInstruction T.Text | InvalidNextIpAddress +data ExecException = ExecException MimaAddress MimaWord AbortReason + +incrementIp :: MimaState -> Either ExecException MimaState +incrementIp ms = + let addr = msIp ms + in if addr >= maxBound + then Left $ ExecException addr (readAt addr $ msMemory ms) InvalidNextIpAddress + else pure ms{msIp = succ addr} + +wordToInstruction' :: MimaAddress -> MimaWord -> Either ExecException Instruction +wordToInstruction' addr word = + case wordToInstruction word of + Right instruction -> pure instruction + Left errorMsg -> Left $ ExecException addr word $ InvalidInstruction errorMsg + +step :: MimaState -> Either ExecException MimaState +step ms = do + let addr = msIp ms + word = readAt addr (msMemory ms) + instruction <- wordToInstruction' addr word + case instruction of + (SmallInstruction oc instrAddr) -> executeSmallOpcode oc instrAddr ms + (LargeInstruction oc) -> executeLargeOpcode oc ms + +executeSmallOpcode :: SmallOpcode -> MimaAddress -> MimaState -> Either ExecException MimaState +executeSmallOpcode LDC addr ms = incrementIp ms{msAcc = fromWord32 $ toWord32 addr} +executeSmallOpcode LDV addr ms = incrementIp ms{msAcc = readAt addr (msMemory ms)} +executeSmallOpcode STV addr ms = incrementIp ms{msMemory = writeAt addr (msAcc ms) (msMemory ms)} +executeSmallOpcode ADD addr ms = incrementIp ms{msAcc = addWords (msAcc ms) (readAt addr $ msMemory ms)} +executeSmallOpcode AND addr ms = incrementIp ms{msAcc = msAcc ms .&. readAt addr (msMemory ms)} +executeSmallOpcode OR addr ms = incrementIp ms{msAcc = msAcc ms .|. readAt addr (msMemory ms)} +executeSmallOpcode XOR addr ms = incrementIp ms{msAcc = msAcc ms `xor` readAt addr (msMemory ms)} +executeSmallOpcode EQL addr ms = incrementIp ms{msAcc = wordFromBool $ msAcc ms == readAt addr (msMemory ms)} +executeSmallOpcode JMP addr ms = pure ms{msIp = addr} +executeSmallOpcode JMN addr ms = if topBit (msAcc ms) then pure ms{msIp = addr} else incrementIp ms + +executeLargeOpcode :: LargeOpcode -> MimaState -> Either ExecException MimaState +executeLargeOpcode HALT ms = + let addr = msIp ms + word = readAt addr (msMemory ms) + in Left $ ExecException addr word Halted +executeLargeOpcode NOT ms = incrementIp ms{msAcc = complement (msAcc ms)} +executeLargeOpcode RAR ms = incrementIp ms{msAcc = rotateR (msAcc ms) 1} diff --git a/src/Mima/Word.hs b/src/Mima/Word.hs index f3ab514..27dc3bc 100644 --- a/src/Mima/Word.hs +++ b/src/Mima/Word.hs @@ -1,10 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + module Mima.Word ( Word32Based(..) , MimaWord + , wordFromBool + , topBit + , addWords , MimaAddress ) where import Data.Bits +import qualified Data.Text as T import Data.Word import Mima.Util @@ -16,25 +22,91 @@ class Word32Based t where -- The MiMa's words are 24 bits long. The smallest word they fit in is -- 'Word32'. +-- TODO Maybe store in the upper 24 bits of a signed type? + newtype MimaWord = MimaWord Word32 - deriving (Show, Eq) + deriving (Eq) + +wordSize :: Int +wordSize = 24 instance ToText MimaWord where toText (MimaWord w) = toHex 6 w +instance Show MimaWord where + show mw = T.unpack $ "MimaWord 0x" <> toText mw + instance Word32Based MimaWord where fromWord32 w = MimaWord $ w .&. 0x00FFFFFF toWord32 (MimaWord w) = w +instance Bits MimaWord where + mw1 .&. mw2 = fromWord32 $ toWord32 mw1 .&. toWord32 mw2 + mw1 .|. mw2 = fromWord32 $ toWord32 mw1 .|. toWord32 mw2 + mw1 `xor` mw2 = fromWord32 $ toWord32 mw1 `xor` toWord32 mw2 + complement = fromWord32 . complement . toWord32 + + shiftR mw i = fromWord32 $ + let rightShifted = shiftR (toWord32 mw) i + leftOver = max 0 (wordSize - i) + in if topBit mw + then shiftL 0xFFFFFFFF leftOver .|. rightShifted + else rightShifted + + shiftL mw i = fromWord32 $ shiftL (toWord32 mw) i + + rotateR mw i = + let i' = i `mod` wordSize + w = toWord32 mw + in fromWord32 $ shiftR w i' .|. shiftL w (wordSize - i') + + rotateL mw i = rotateR mw (wordSize - i) + + zeroBits = fromWord32 zeroBits + bit = fromWord32 . bit + testBit mw i = testBit (toWord32 mw) i + bitSize = const wordSize + bitSizeMaybe = const (Just wordSize) + isSigned = const True + popCount = popCount . toWord32 + +wordFromBool :: Bool -> MimaWord +wordFromBool False = zeroBits +wordFromBool True = complement zeroBits + +topBit :: MimaWord -> Bool +topBit mw = testBit (toWord32 mw) (wordSize - 1) + +addWords :: MimaWord -> MimaWord -> MimaWord +addWords mw1 mw2 = fromWord32 $ toWord32 mw1 + toWord32 mw2 + -- The MiMa's addresses are 20 bits long. The smallest word they fit -- in is 'Word32'. newtype MimaAddress = MimaAddress Word32 - deriving (Show, Eq) + deriving (Eq, Ord) instance ToText MimaAddress where toText (MimaAddress w) = toHex 5 w +instance Show MimaAddress where + show ma = T.unpack $ "MimaAddress 0x" <> toText ma + instance Word32Based MimaAddress where fromWord32 w = MimaAddress $ w .&. 0x000FFFFF toWord32 (MimaAddress w) = w + +instance Bounded MimaAddress where + minBound = fromWord32 0x00000 + maxBound = fromWord32 0xFFFFF + +-- TODO satisfy enum laws with regards to bounded instance +instance Enum MimaAddress where + toEnum i = + let lower = fromEnum $ toWord32 (minBound :: MimaAddress) + upper = fromEnum $ toWord32 (maxBound :: MimaAddress) + in if lower <= i && i <= upper + then fromWord32 $ toEnum i + else error $ "Enum.toEnum{MimaAddress}: tag (" ++ show i + ++ ") is out of bounds " ++ show (lower, upper) + fromEnum = fromEnum . toWord32