diff --git a/package.yaml b/package.yaml index 758e1a9..6a6df78 100644 --- a/package.yaml +++ b/package.yaml @@ -20,6 +20,10 @@ description: Please see the README on GitHub at = 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 library: source-dirs: src diff --git a/src/Mima/Instruction.hs b/src/Mima/Instruction.hs new file mode 100644 index 0000000..768f7b6 --- /dev/null +++ b/src/Mima/Instruction.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Mima.Instruction + ( SmallOpcode(..) + , LargeOpcode(..) + , Instruction(..) + , instructionFromWord + ) where + +import Data.Bits +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Word + +import Mima.Util +import Mima.Word + +data SmallOpcode = LDC | LDV | STV | ADD | AND | OR | XOR | EQL | JMP | JMN + deriving (Show, Eq, Ord) + +instance ToText SmallOpcode where + toText = T.pack . show + +allSmallOpcodes :: [SmallOpcode] +allSmallOpcodes = [LDC, LDV, STV, ADD, AND, OR, XOR, EQL, JMP, JMN] + +getSmallOpcode :: SmallOpcode -> Word32 +getSmallOpcode LDC = 0 +getSmallOpcode LDV = 1 +getSmallOpcode STV = 2 +getSmallOpcode ADD = 3 +getSmallOpcode AND = 4 +getSmallOpcode OR = 5 +getSmallOpcode XOR = 6 +getSmallOpcode EQL = 7 +getSmallOpcode JMP = 8 +getSmallOpcode JMN = 9 + +smallOpcodeMap :: Map.Map Word32 SmallOpcode +smallOpcodeMap = Map.fromList [(getSmallOpcode oc, oc) | oc <- allSmallOpcodes] + +data LargeOpcode = HALT | NOT | RAR + deriving (Show, Eq, Ord) + +instance ToText LargeOpcode where + toText = T.pack . show + +allLargeOpcodes :: [LargeOpcode] +allLargeOpcodes = [HALT, NOT, RAR] + +getLargeOpcode :: LargeOpcode -> Word32 +getLargeOpcode HALT = 0 +getLargeOpcode NOT = 1 +getLargeOpcode RAR = 2 + +largeOpcodeMap :: Map.Map Word32 LargeOpcode +largeOpcodeMap = Map.fromList [(getLargeOpcode oc, oc) | oc <- allLargeOpcodes] + +data Instruction + = SmallInstruction SmallOpcode MimaAddress + | LargeInstruction LargeOpcode + deriving (Show, Eq) + +instance ToText Instruction where + toText (SmallInstruction oc addr) = toText oc <> " " <> toText addr + toText (LargeInstruction oc) = toText oc + +upperOpcode :: MimaWord -> Word32 +upperOpcode mw = shiftR (toWord32 mw) 20 .&. 0xF + +lowerOpcode :: MimaWord -> Word32 +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 + +parseSmallInstruction :: MimaWord -> Either T.Text Instruction +parseSmallInstruction mw = do + oc <- parseSmallOpcode (upperOpcode mw) + pure $ SmallInstruction oc (address mw) + +-- Assumes that all bits not part of the opcode are zeroed. The opcode +-- uses the lowest four bits. +parseSmallOpcode :: Word32 -> Either T.Text SmallOpcode +parseSmallOpcode w = case smallOpcodeMap Map.!? w of + Just oc -> pure oc + Nothing -> Left $ "Unknown small opcode " <> T.pack (show w) + <> " (" <> toHex 2 w <> ")" + +parseLargeInstruction :: MimaWord -> Either T.Text Instruction +parseLargeInstruction mw = LargeInstruction <$> parseLargeOpcode (lowerOpcode mw) + +-- Assumes that all bits not part of the opcode are zeroed. The opcode +-- uses the lowest four bits. +parseLargeOpcode :: Word32 -> Either T.Text LargeOpcode +parseLargeOpcode w = case largeOpcodeMap Map.!? w of + Just oc -> pure oc + Nothing -> Left $ "Unknown large opcode " <> T.pack (show w) + <> " (" <> toHex 2 w <> ")" diff --git a/src/Mima/Util.hs b/src/Mima/Util.hs new file mode 100644 index 0000000..44f18bf --- /dev/null +++ b/src/Mima/Util.hs @@ -0,0 +1,23 @@ +module Mima.Util + ( ToText(..) + , toHex + ) where + +import qualified Data.Text as T +import qualified Numeric as N + +-- | A class for types that can be converted to 'T.Text'. +-- +-- This class does not mean to convert elements to text in a +-- standardized way. It is just to reduce the clutter of functions +-- with names like @somethingToText@. +-- +-- Only create an instance of this class when there is an obvious, +-- preferrable way of converting something to text! If there are +-- multiple "obvious" options, create no instance of this class and +-- instead name the functions individually. +class ToText a where + toText :: a -> T.Text + +toHex :: (Integral a, Show a) => Int -> a -> T.Text +toHex digits a = T.justifyRight digits '0' $ T.pack $ N.showHex a "" diff --git a/src/Mima/Word.hs b/src/Mima/Word.hs new file mode 100644 index 0000000..a3296b7 --- /dev/null +++ b/src/Mima/Word.hs @@ -0,0 +1,36 @@ +module Mima.Word where + +import Data.Bits +import Data.Word + +import Mima.Util + +class Word32Based t where + fromWord32 :: Word32 -> t + toWord32 :: t -> Word32 + +-- The MiMa's words are 24 bits long. The smallest word they fit in is +-- 'Word32'. + +newtype MimaWord = MimaWord Word32 + deriving (Show, Eq) + +instance ToText MimaWord where + toText (MimaWord w) = toHex 6 w + +instance Word32Based MimaWord where + fromWord32 w = MimaWord $ w .&. 0x00FFFFFF + toWord32 (MimaWord w) = w + +-- The MiMa's addresses are 20 bits long. The smallest word they fit +-- in is 'Word32'. + +newtype MimaAddress = MimaAddress Word32 + deriving (Show, Eq) + +instance ToText MimaAddress where + toText (MimaAddress w) = toHex 5 w + +instance Word32Based MimaAddress where + fromWord32 w = MimaAddress $ w .&. 0x000FFFFF + toWord32 (MimaAddress w) = w