From 112a49a7b7cbf967fedfda3e2dcfa76607a7a948 Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 8 Nov 2019 18:33:08 +0000 Subject: [PATCH] Use OddWords library --- src/Mima/Instruction.hs | 70 ++++++----- src/Mima/Load.hs | 15 +-- src/Mima/State.hs | 47 ++------ src/Mima/Util.hs | 29 ++++- src/Mima/Word.hs | 251 +++++++--------------------------------- 5 files changed, 120 insertions(+), 292 deletions(-) diff --git a/src/Mima/Instruction.hs b/src/Mima/Instruction.hs index 547115f..da411e1 100644 --- a/src/Mima/Instruction.hs +++ b/src/Mima/Instruction.hs @@ -9,7 +9,6 @@ module Mima.Instruction import qualified Data.Map.Strict as Map import qualified Data.Text as T -import Data.Word import Mima.Util import Mima.Word @@ -25,25 +24,25 @@ allSmallOpcodes :: [SmallOpcode] allSmallOpcodes = [LDC, LDV, STV, ADD, AND, OR, XOR, EQL, JMP, JMN, LDIV, STIV, CALL, LDVR, STVR] -smallOpcodeToWord32 :: SmallOpcode -> Word32 -smallOpcodeToWord32 LDC = 0 -smallOpcodeToWord32 LDV = 1 -smallOpcodeToWord32 STV = 2 -smallOpcodeToWord32 ADD = 3 -smallOpcodeToWord32 AND = 4 -smallOpcodeToWord32 OR = 5 -smallOpcodeToWord32 XOR = 6 -smallOpcodeToWord32 EQL = 7 -smallOpcodeToWord32 JMP = 8 -smallOpcodeToWord32 JMN = 9 -smallOpcodeToWord32 LDIV = 10 -smallOpcodeToWord32 STIV = 11 -smallOpcodeToWord32 CALL = 12 -smallOpcodeToWord32 LDVR = 13 -smallOpcodeToWord32 STVR = 14 +smallOpcodeNr :: SmallOpcode -> Opcode +smallOpcodeNr LDC = 0 +smallOpcodeNr LDV = 1 +smallOpcodeNr STV = 2 +smallOpcodeNr ADD = 3 +smallOpcodeNr AND = 4 +smallOpcodeNr OR = 5 +smallOpcodeNr XOR = 6 +smallOpcodeNr EQL = 7 +smallOpcodeNr JMP = 8 +smallOpcodeNr JMN = 9 +smallOpcodeNr LDIV = 10 +smallOpcodeNr STIV = 11 +smallOpcodeNr CALL = 12 +smallOpcodeNr LDVR = 13 +smallOpcodeNr STVR = 14 -smallOpcodeMap :: Map.Map Word32 SmallOpcode -smallOpcodeMap = Map.fromList [(smallOpcodeToWord32 so, so) | so <- allSmallOpcodes] +smallOpcodeMap :: Map.Map Opcode SmallOpcode +smallOpcodeMap = Map.fromList [(smallOpcodeNr so, so) | so <- allSmallOpcodes] data LargeOpcode = HALT | NOT | RAR | RET | LDRA | STRA | LDSP | STSP | LDFP | STFP | ADC @@ -55,22 +54,21 @@ instance ToText LargeOpcode where allLargeOpcodes :: [LargeOpcode] allLargeOpcodes = [HALT, NOT, RAR, RET, LDRA, STRA, LDSP, STSP, LDFP, STFP, ADC] -largeOpcodeToWord32 :: LargeOpcode -> Word32 -largeOpcodeToWord32 HALT = 0 -largeOpcodeToWord32 NOT = 1 -largeOpcodeToWord32 RAR = 2 -largeOpcodeToWord32 RET = 3 +largeOpcodeNr :: LargeOpcode -> Opcode +largeOpcodeNr HALT = 0 +largeOpcodeNr NOT = 1 +largeOpcodeNr RAR = 2 +largeOpcodeNr RET = 3 +largeOpcodeNr LDRA = 4 +largeOpcodeNr STRA = 5 +largeOpcodeNr LDSP = 6 +largeOpcodeNr STSP = 7 +largeOpcodeNr LDFP = 8 +largeOpcodeNr STFP = 9 +largeOpcodeNr ADC = 10 -largeOpcodeToWord32 LDRA = 4 -largeOpcodeToWord32 STRA = 5 -largeOpcodeToWord32 LDSP = 6 -largeOpcodeToWord32 STSP = 7 -largeOpcodeToWord32 LDFP = 8 -largeOpcodeToWord32 STFP = 9 -largeOpcodeToWord32 ADC = 10 - -largeOpcodeMap :: Map.Map Word32 LargeOpcode -largeOpcodeMap = Map.fromList [(largeOpcodeToWord32 lo, lo) | lo <- allLargeOpcodes] +largeOpcodeMap :: Map.Map Opcode LargeOpcode +largeOpcodeMap = Map.fromList [(largeOpcodeNr lo, lo) | lo <- allLargeOpcodes] data Instruction = SmallInstruction !SmallOpcode !LargeValue @@ -89,7 +87,7 @@ parseSmallInstruction mw = do -- 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 :: Opcode -> Either T.Text SmallOpcode parseSmallOpcode w = case smallOpcodeMap Map.!? w of Just oc -> pure oc Nothing -> Left $ "Unknown small opcode " <> T.pack (show w) @@ -102,7 +100,7 @@ parseLargeInstruction mw = do -- 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 :: Opcode -> Either T.Text LargeOpcode parseLargeOpcode w = case largeOpcodeMap Map.!? w of Just oc -> pure oc Nothing -> Left $ "Unknown large opcode " <> T.pack (show w) diff --git a/src/Mima/Load.hs b/src/Mima/Load.hs index 635a9a5..97516e7 100644 --- a/src/Mima/Load.hs +++ b/src/Mima/Load.hs @@ -6,6 +6,7 @@ module Mima.Load ) where import Control.Applicative +import Control.Monad import Data.Binary import qualified Data.ByteString.Lazy as BS @@ -15,19 +16,15 @@ import Mima.State -- To prevent orphan instances and keep the compiler happy newtype LD t = LD { unLD :: t } -instance Binary (LD (WB MimaWord_)) where +instance Binary (LD MimaWord) where put mw = do let (w1, w2, w3) = wordToBytes $ unLD mw - put w1 - put w2 - put w3 + forM_ [w1, w2, w3] put get = do - w1 <- get - w2 <- get - w3 <- get - pure $ LD $ bytesToWord w1 w2 w3 + bytes <- (,,) <$> get <*> get <*> get + pure $ LD $ bytesToWord bytes -instance Binary (LD (WB LargeValue_)) where +instance Binary (LD LargeValue) where put = put . LD . largeValueToWord . unLD get = (LD . getLargeValue) <$> unLD <$> get diff --git a/src/Mima/State.hs b/src/Mima/State.hs index ff96971..694a41e 100644 --- a/src/Mima/State.hs +++ b/src/Mima/State.hs @@ -51,35 +51,6 @@ wordsToMemory = MimaMemory memoryToWords :: MimaMemory -> [MimaWord] memoryToWords mem = map (\addr -> readAt addr mem) $ addressRange mem -{- -addrWordLegend :: T.Text -addrWordLegend = "SO: Small Opcode (bits 23-20) LO: Large Opcode (bits 19-16)\n" - <> "Addr (decimal) - Word ( decimal|SO,LO, Addr) - Instruction\n" - -addrWordToText :: MimaAddress -> MimaWord -> T.Text -addrWordToText addr word = - let separator = " - " - addrText = addrToHex addr <> " (" <> addrToDec addr <> ")" - wordSplit = toDec 2 (upperOpcode word) <> "," - <> toDec 2 (lowerOpcode word) <> "," - <> addrToDec (address word) - wordText = wordToHex word <> " (" <> wordToDec word <> "|" <> wordSplit <> ")" - instrText = case wordToInstruction word of - Left _ -> "" - Right i -> separator <> toText i - in addrText <> separator <> wordText <> instrText - -memoryToText :: Bool -> MimaMemory -> T.Text -memoryToText sparse mem@(MimaMemory m) - = (addrWordLegend <>) - $ T.intercalate "\n" - $ map (\addr -> addrWordToText addr (readAt addr mem)) - $ addresses sparse - where - addresses False = addressRange mem - addresses True = Map.keys m --} - readAt :: MimaAddress -> MimaMemory -> MimaWord readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m @@ -143,7 +114,7 @@ doSmallOpcode :: SmallOpcode -> LargeValue -> MimaState -> MimaState doSmallOpcode LDC lv ms@MimaState{..} = ms{msACC = largeValueToWord lv} doSmallOpcode LDV addr ms@MimaState{..} = ms{msACC = readAt addr msMemory} doSmallOpcode STV addr ms@MimaState{..} = ms{msMemory = writeAt addr msACC msMemory} -doSmallOpcode ADD addr ms@MimaState{..} = ms{msACC = addWords msACC $ readAt addr msMemory} +doSmallOpcode ADD addr ms@MimaState{..} = ms{msACC = msACC + readAt addr msMemory} doSmallOpcode AND addr ms@MimaState{..} = ms{msACC = msACC .&. readAt addr msMemory} doSmallOpcode OR addr ms@MimaState{..} = ms{msACC = msACC .|. readAt addr msMemory} doSmallOpcode XOR addr ms@MimaState{..} = ms{msACC = msACC `xor` readAt addr msMemory} @@ -151,14 +122,14 @@ doSmallOpcode EQL addr ms@MimaState{..} = ms{msACC = boolToWord $ msACC == read doSmallOpcode JMP addr ms@MimaState{..} = ms{msIAR = addr} doSmallOpcode JMN addr ms@MimaState{..} = if topBit msACC then ms{msIAR = addr} else ms doSmallOpcode LDIV addr ms@MimaState{..} = - let indirAddr = getAddress $ readAt addr msMemory + let indirAddr = getLargeValue $ readAt addr msMemory in ms{msACC = readAt indirAddr msMemory} doSmallOpcode STIV addr ms@MimaState{..} = - let indirAddr = getAddress $ readAt addr msMemory + let indirAddr = getLargeValue $ readAt addr msMemory in ms{msMemory = writeAt indirAddr msACC msMemory} doSmallOpcode CALL addr ms@MimaState{..} = ms{msRA = msIAR, msIAR = addr} -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} +doSmallOpcode LDVR addr ms@MimaState{..} = ms{msACC = readAt (msSP + addr) msMemory} +doSmallOpcode STVR addr ms@MimaState{..} = ms{msMemory = writeAt (msSP + addr) msACC msMemory} doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Either AbortReason MimaState doLargeOpcode HALT _ _ = Left Halted @@ -166,12 +137,12 @@ doLargeOpcode NOT _ ms@MimaState{..} = pure ms{msACC = complement msACC} doLargeOpcode RAR _ ms@MimaState{..} = pure ms{msACC = rotateR msACC 1} doLargeOpcode RET _ ms@MimaState{..} = pure ms{msIAR = msRA} doLargeOpcode LDRA _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msRA} -doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRA = getAddress msACC} +doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRA = getLargeValue msACC} doLargeOpcode LDSP _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msSP} -doLargeOpcode STSP _ ms@MimaState{..} = pure ms{msSP = getAddress msACC} +doLargeOpcode STSP _ ms@MimaState{..} = pure ms{msSP = getLargeValue 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} +doLargeOpcode STFP _ ms@MimaState{..} = pure ms{msFP = getLargeValue msACC} +doLargeOpcode ADC sv ms@MimaState{..} = pure ms{msACC = msACC + signedSmallValueToWord sv} run :: MimaState -> (MimaState, AbortReason, Integer) run ms = helper 0 ms diff --git a/src/Mima/Util.hs b/src/Mima/Util.hs index cb050f6..e896009 100644 --- a/src/Mima/Util.hs +++ b/src/Mima/Util.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} module Mima.Util - ( ToText(..) + ( + -- * Formatting + ToText(..) , HexLike(..) , groupByTwoChars , integralToDec @@ -9,8 +13,12 @@ module Mima.Util ) where import qualified Data.Text as T +import Data.Word +import Data.Word.Odd import qualified Numeric as N +{- Formatting -} + -- | A class for types that can be converted to 'T.Text'. -- -- This class does not mean to convert elements to text in a @@ -24,6 +32,8 @@ import qualified Numeric as N class ToText a where toText :: a -> T.Text +-- | A class for number-like types that have a decimal and a +-- hexadecimal representation. class HexLike a where toDec :: a -> T.Text toHex :: a -> T.Text @@ -31,6 +41,23 @@ class HexLike a where toHexBytes :: a -> T.Text toHexBytes = T.intercalate " " . groupByTwoChars . toHex +instance HexLike Word24 where + toHex = integralToHex 6 + toDec = T.pack . show + +instance HexLike Word20 where + toHex = integralToHex 5 + toDec = T.pack . show + +instance HexLike Word16 where + toHex = integralToHex 4 + toDec = T.pack . show + +instance HexLike Word4 where + toHex = integralToHex 1 + toDec = T.pack . show + + groupByTwoChars :: T.Text -> [T.Text] groupByTwoChars = reverse . helper . T.unpack . T.reverse where diff --git a/src/Mima/Word.hs b/src/Mima/Word.hs index 62b3a8f..b9a54ea 100644 --- a/src/Mima/Word.hs +++ b/src/Mima/Word.hs @@ -1,237 +1,72 @@ -{-# LANGUAGE OverloadedStrings #-} - module Mima.Word - ( topBit - -- * 24-bit value - , MimaWord - -- ** Converting + ( + -- * Types + MimaWord + , MimaAddress + , LargeValue + , SmallValue + , Opcode + , topBit + -- * Converting between types , bytesToWord , wordToBytes , boolToWord - -- ** Properties + , largeValueToWord + , signedSmallValueToWord + -- ** 'MimaWord' properties , getSmallOpcode , getLargeOpcode - , getAddress , getLargeValue , getSmallValue - -- ** Operations - , addWords - -- * 20-bit value - , LargeValue - , MimaAddress - -- ** Converting - , bytesToLargeValue - , largeValueToBytes - , largeValueToWord - -- ** Operations - , addLargeValues - -- * 16-bit value - , SmallValue - -- ** Converting - , signedSmallValueToWord - -- * Underlying types - , WB - , MimaWord_ - , LargeValue_ - , SmallValue_ ) where import Data.Bits -import Data.Function -import qualified Data.Text as T import Data.Word +import Data.Word.Odd -import Mima.Util +type MimaWord = Word24 +type MimaAddress = LargeValue +type LargeValue = Word20 +type SmallValue = Word16 +type Opcode = Word4 -{- Type classes and instances for free! -} --- Get them now while they're hot! +topBit :: (FiniteBits b) => b -> Bool +topBit b = testBit b $ finiteBitSize b --- This typeclass is for automatic bit twiddling and enumification for --- 'Word32' based types. -class Word32Based t where - usedBits :: t -> Int - fromWord32 :: Word32 -> t - toWord32 :: t -> Word32 - -topBit :: (Word32Based t) => t -> Bool -topBit t = testBit (toWord32 t) (usedBits t - 1) - --- Required to make the compiler shut up (see --- https://stackoverflow.com/a/17866970) -newtype WB t = WB { unWB :: t} - -instance (Show t) => Show (WB t) where - show = show . unWB - -instance (HexLike t) => HexLike (WB t) where - toDec = toDec . unWB - toHex = toHex . unWB - toHexBytes = toHexBytes . unWB - --- Kinda obvious, isn't it? :P -instance (Word32Based t) => Word32Based (WB t) where - usedBits = usedBits . unWB - fromWord32 = WB . fromWord32 - toWord32 = toWord32 . unWB - -instance (Word32Based t) => Eq (WB t) where - 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 - t1 .&. t2 = fromWord32 $ toWord32 t1 .&. toWord32 t2 - t1 .|. t2 = fromWord32 $ toWord32 t1 .|. toWord32 t2 - t1 `xor` t2 = fromWord32 $ toWord32 t1 `xor` toWord32 t2 - complement = fromWord32 . complement . toWord32 - - shiftL t i = fromWord32 $ shiftL (toWord32 t) i - shiftR t i = fromWord32 $ - let rightShifted = shiftR (toWord32 t) i - leftOver = max 0 (usedBits t - i) - in if topBit t - then shiftL (complement zeroBits) leftOver .|. rightShifted - else rightShifted - - rotateL t i = rotateR t (usedBits t - i) - rotateR t i = - let i' = i `mod` usedBits t - w = toWord32 t - in fromWord32 $ shiftR w i' .|. shiftL w (usedBits t - i') - - zeroBits = fromWord32 zeroBits - bit = fromWord32 . bit - testBit t = testBit (toWord32 t) - bitSize = usedBits - bitSizeMaybe = Just . usedBits - isSigned = const True - popCount = popCount . toWord32 - -instance (Word32Based t) => Bounded (WB t) where - minBound = fromWord32 zeroBits - maxBound = fromWord32 (complement zeroBits) - -instance (Word32Based t) => Enum (WB t) 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: tag (" ++ show i - ++ ") is out of bounds " ++ show (lower, upper) - - fromEnum = fromEnum . toWord32 - - -- See 'Enum' laws for types with a 'Bounded' instance - enumFrom x = enumFromTo x maxBound - enumFromThen x y = enumFromThenTo x y bound - where - bound | fromEnum y >= fromEnum x = maxBound - | otherwise = minBound - -{- The types -} - -type MimaWord = WB MimaWord_ -newtype MimaWord_ = MimaWord_ Word32 - -instance Word32Based MimaWord_ where - usedBits _ = 24 - fromWord32 w = MimaWord_ $ w .&. 0xFFFFFF - toWord32 (MimaWord_ w) = w - -instance HexLike MimaWord_ where - toDec = T.pack . show . toWord32 - toHex = integralToHex 6 . toWord32 - -instance Show MimaWord_ where - show mw = T.unpack $ "MimaWord_ 0x" <> toHex mw - -bytesToWord :: Word8 -> Word8 -> Word8 -> MimaWord -bytesToWord w1 w2 w3 = +bytesToWord :: (Word8, Word8, Word8) -> MimaWord +bytesToWord (w1, w2, w3) = let (w1', w2', w3') = (fromIntegral w1, fromIntegral w2, fromIntegral w3) - in fromWord32 $ shiftL w1' 16 .|. shiftL w2' 8 .|. w3' + in shiftL w1' 16 .|. shiftL w2' 8 .|. w3' wordToBytes :: MimaWord -> (Word8, Word8, Word8) wordToBytes mw = - let w = toWord32 mw - -- Mask for w1 not strictly necessary, since upper bytes are - -- already zero due to implementation of 'fromWord32'. - w1 = fromIntegral $ shiftR w 16 .&. 0xFF - w2 = fromIntegral $ shiftR w 8 .&. 0xFF - w3 = fromIntegral $ w .&. 0xFF + -- No masks necessary since converting to 'Word8' already cuts off + -- all higher bits. + let w1 = fromIntegral $ shiftR mw 16 + w2 = fromIntegral $ shiftR mw 8 + w3 = fromIntegral mw in (w1, w2, w3) boolToWord :: Bool -> MimaWord boolToWord False = zeroBits boolToWord True = complement zeroBits -getSmallOpcode :: MimaWord -> Word32 -getSmallOpcode mw = shiftR (toWord32 mw) 20 .&. 0xF - -getLargeOpcode :: MimaWord -> Word32 -getLargeOpcode mw = shiftR (toWord32 mw) 16 .&. 0xF - -getAddress :: MimaWord -> MimaAddress -getAddress = getLargeValue - -getLargeValue :: MimaWord -> LargeValue -getLargeValue = fromWord32 . toWord32 - -getSmallValue :: MimaWord -> SmallValue -getSmallValue = fromWord32 . toWord32 - -addWords :: MimaWord -> MimaWord -> MimaWord -addWords w1 w2 = fromWord32 $ toWord32 w1 + toWord32 w2 - -type MimaAddress = LargeValue -type LargeValue = WB LargeValue_ -newtype LargeValue_ = LargeValue_ Word32 - -instance Word32Based LargeValue_ where - usedBits _ = 20 - fromWord32 w = LargeValue_ $ w .&. 0xFFFFF - toWord32 (LargeValue_ w) = w - -instance HexLike LargeValue_ where - toDec = T.pack . show . toWord32 - toHex = integralToHex 5 . toWord32 - -instance Show LargeValue_ where - show lv = T.unpack $ "LargeValue_ 0x" <> toHex lv - -bytesToLargeValue :: Word8 -> Word8 -> Word8 -> LargeValue -bytesToLargeValue w1 w2 w3 = getAddress $ bytesToWord w1 w2 w3 - -largeValueToBytes :: LargeValue -> (Word8, Word8, Word8) -largeValueToBytes = wordToBytes . largeValueToWord - largeValueToWord :: LargeValue -> MimaWord -largeValueToWord = fromWord32 . toWord32 - -addLargeValues :: LargeValue -> LargeValue -> LargeValue -addLargeValues lv1 lv2 = getLargeValue $ addWords (largeValueToWord lv1) (largeValueToWord lv2) - -type SmallValue = WB SmallValue_ -newtype SmallValue_ = SmallValue_ Word32 - -instance Word32Based SmallValue_ where - usedBits _ = 16 - fromWord32 w = SmallValue_ $ w .&. 0xFFFF - toWord32 (SmallValue_ w) = w - -instance HexLike SmallValue_ where - toDec = T.pack . show . toWord32 - toHex = integralToHex 5 . toWord32 - -instance Show SmallValue_ where - show sv = T.unpack $ "SmallValue_ 0x" <> toHex sv +largeValueToWord = fromIntegral signedSmallValueToWord :: SmallValue -> MimaWord signedSmallValueToWord sv - | topBit sv = fromWord32 $ 0xFFFF0000 .|. toWord32 sv - | otherwise = fromWord32 $ toWord32 sv + | topBit sv = 0xFF0000 .|. fromIntegral sv + | otherwise = fromIntegral sv + +getSmallOpcode :: MimaWord -> Opcode +getSmallOpcode mw = fromIntegral $ shiftR mw 20 + +getLargeOpcode :: MimaWord -> Opcode +getLargeOpcode mw = fromIntegral $ shiftR mw 16 + +getLargeValue :: MimaWord -> LargeValue +getLargeValue = fromIntegral + +getSmallValue :: MimaWord -> SmallValue +getSmallValue = fromIntegral