Execute a MiMa state

package.yaml

@@ -19,8 +19,8 @@ extra-source-files:
 description:         Please see the README on GitHub at <https://github.com/Garmelon/mima-tools#readme>
 
 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

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

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}

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