From 3eb9430208d721531e125c8db514ea376740d872 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 7 Nov 2019 09:48:29 +0000 Subject: [PATCH] Change low-level data types This commit reorganizes and restructures the low level data types, like the MimaWord, in preparation for implementing the new MiMa specification. --- src/Mima/Word.hs | 265 +++++++++++++++++++++++++++++------------------ 1 file changed, 167 insertions(+), 98 deletions(-) diff --git a/src/Mima/Word.hs b/src/Mima/Word.hs index b483e7b..2113c40 100644 --- a/src/Mima/Word.hs +++ b/src/Mima/Word.hs @@ -1,33 +1,44 @@ {-# LANGUAGE OverloadedStrings #-} module Mima.Word - ( - -- * MiMa-Word - MimaWord + ( topBit + -- * 24-bit value + , MimaWord -- ** Formatting - , wordToDec , wordToHex + , wordToDec , wordToHexDec -- ** Converting , bytesToWord , wordToBytes , boolToWord - -- ** Querying - , wordSize - , topBit - , upperOpcode - , lowerOpcode - , address - -- ** Adding + -- ** Properties + , getSmallOpcode + , getLargeOpcode + , getAddress + , getLongValue + , getShortValue + -- ** Operations , addWords - -- * MiMa-Addresses + -- * 20-bit value + , LongValue , MimaAddress -- ** Formatting - , addrToDec - , addrToHex - , addrToHexDec + , longValueToHex + , longValueToDec + , longValueToHexDec -- ** Converting - , addrToWord + , bytesToLongValue + , longValueToBytes + , longValueToWord + -- * 16-bit value + , ShortValue + -- ** Formatting + , shortValueToHex + , shortValueToDec + , shortValueToHexDec + -- ** Converting + , signedShortValueToWord ) where import Data.Bits @@ -36,67 +47,107 @@ import Data.Word import Mima.Util +{- Type classes and instances for free! -} +-- Get them now while they're hot! + +-- 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 --- The MiMa's words are 24 bits long. The smallest word they fit in is --- 'Word32'. +topBit :: (Word32Based t) => t -> Bool +topBit t = testBit (toWord32 t) (usedBits t - 1) --- TODO Maybe store in the upper 24 bits of a signed type? +-- Required to make the compiler shut up (see +-- https://stackoverflow.com/a/17866970) +newtype WB t = WB { unWB :: t} -newtype MimaWord = MimaWord Word32 - deriving (Eq) +instance (Show t) => Show (WB t) where + show = show . unWB -wordSize :: Int -wordSize = 24 +-- Kinda obvious, isn't it? :P +instance (Word32Based t) => Word32Based (WB t) where + usedBits = usedBits . unWB + fromWord32 = WB . fromWord32 + toWord32 = toWord32 . unWB -wordToDec :: MimaWord -> T.Text -wordToDec (MimaWord w) = toDec 8 w +instance (Word32Based t) => Eq (WB t) where + w1 == w2 = toWord32 (unWB w1) == toWord32 (unWB w2) -wordToHex :: MimaWord -> T.Text -wordToHex (MimaWord w) = toHex 6 w - -wordToHexDec :: MimaWord -> T.Text -wordToHexDec mw = wordToHex mw <> " (" <> wordToDec mw <> ")" - -instance Show MimaWord where - show mw = T.unpack $ "MimaWord 0x" <> wordToHex 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 +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 - shiftR mw i = fromWord32 $ - let rightShifted = shiftR (toWord32 mw) i - leftOver = max 0 (wordSize - i) - in if topBit mw - then shiftL 0xFFFFFFFF leftOver .|. rightShifted + 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 - 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) + 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 mw i = testBit (toWord32 mw) i - bitSize = const wordSize - bitSizeMaybe = const (Just wordSize) + 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 Show MimaWord_ where + show mw = T.unpack $ "MimaWord_ 0x" <> toHex 6 (toWord32 mw) + +wordToHex :: MimaWord -> T.Text +wordToHex = toHex 6 . toWord32 + +wordToDec :: MimaWord -> T.Text +wordToDec = toDec 8 . toWord32 + +wordToHexDec :: MimaWord -> T.Text +wordToHexDec mw = wordToHex mw <> " (" <> wordToDec mw <> ")" + bytesToWord :: Word8 -> Word8 -> Word8 -> MimaWord bytesToWord w1 w2 w3 = let (w1', w2', w3') = (fromIntegral w1, fromIntegral w2, fromIntegral w3) @@ -114,59 +165,77 @@ wordToBytes mw = boolToWord :: Bool -> MimaWord boolToWord False = zeroBits -boolToWord True = complement zeroBits +boolToWord True = complement zeroBits -topBit :: MimaWord -> Bool -topBit mw = testBit (toWord32 mw) (wordSize - 1) +getSmallOpcode :: MimaWord -> Word32 +getSmallOpcode mw = shiftR (toWord32 mw) 20 .&. 0xF -upperOpcode :: MimaWord -> Word32 -upperOpcode mw = shiftR (toWord32 mw) 20 .&. 0xF +getLargeOpcode :: MimaWord -> Word32 +getLargeOpcode mw = shiftR (toWord32 mw) 16 .&. 0xF -lowerOpcode :: MimaWord -> Word32 -lowerOpcode mw = shiftR (toWord32 mw) 16 .&. 0xF +getAddress :: MimaWord -> MimaAddress +getAddress = getLongValue -address :: MimaWord -> MimaAddress -address = fromWord32 . toWord32 +getLongValue :: MimaWord -> LongValue +getLongValue = fromWord32 . toWord32 + +getShortValue :: MimaWord -> ShortValue +getShortValue = fromWord32 . toWord32 addWords :: MimaWord -> MimaWord -> MimaWord -addWords mw1 mw2 = fromWord32 $ toWord32 mw1 + toWord32 mw2 +addWords w1 w2 = fromWord32 $ toWord32 w1 + toWord32 w2 --- The MiMa's addresses are 20 bits long. The smallest word they fit --- in is 'Word32'. +type MimaAddress = LongValue +type LongValue = WB LongValue_ +newtype LongValue_ = LongValue_ Word32 -newtype MimaAddress = MimaAddress Word32 - deriving (Eq, Ord) +instance Word32Based LongValue_ where + usedBits _ = 20 + fromWord32 w = LongValue_ $ w .&. 0xFFFFF + toWord32 (LongValue_ w) = w -addrToDec :: MimaAddress -> T.Text -addrToDec (MimaAddress a) = toDec 7 a +instance Show LongValue_ where + show lv = T.unpack $ "LongValue_ 0x" <> toHex 5 (toWord32 lv) -addrToHex :: MimaAddress -> T.Text -addrToHex (MimaAddress a) = toHex 5 a +longValueToHex :: MimaWord -> T.Text +longValueToHex = toHex 5 . toWord32 -addrToHexDec :: MimaAddress -> T.Text -addrToHexDec ma = addrToHex ma <> " (" <> addrToDec ma <> ")" +longValueToDec :: MimaWord -> T.Text +longValueToDec = toDec 7 . toWord32 -instance Show MimaAddress where - show ma = T.unpack $ "MimaAddress 0x" <> addrToHex ma +longValueToHexDec :: MimaWord -> T.Text +longValueToHexDec mw = longValueToHex mw <> " (" <> longValueToDec mw <> ")" -instance Word32Based MimaAddress where - fromWord32 w = MimaAddress $ w .&. 0x000FFFFF - toWord32 (MimaAddress w) = w +bytesToLongValue :: Word8 -> Word8 -> Word8 -> LongValue +bytesToLongValue w1 w2 w3 = getAddress $ bytesToWord w1 w2 w3 -instance Bounded MimaAddress where - minBound = fromWord32 0x00000 - maxBound = fromWord32 0xFFFFF +longValueToBytes :: LongValue -> (Word8, Word8, Word8) +longValueToBytes = wordToBytes . longValueToWord --- 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 +longValueToWord :: LongValue -> MimaWord +longValueToWord = fromWord32 . toWord32 -addrToWord :: MimaAddress -> MimaWord -addrToWord = fromWord32 . toWord32 +type ShortValue = WB ShortValue_ +newtype ShortValue_ = ShortValue_ Word32 + +instance Word32Based ShortValue_ where + usedBits _ = 16 + fromWord32 w = ShortValue_ $ w .&. 0xFFFF + toWord32 (ShortValue_ w) = w + +instance Show ShortValue_ where + show lv = T.unpack $ "ShortValue_ 0x" <> toHex 4 (toWord32 lv) + +shortValueToHex :: MimaWord -> T.Text +shortValueToHex = toHex 4 . toWord32 + +shortValueToDec :: MimaWord -> T.Text +shortValueToDec = toDec 5 . toWord32 + +shortValueToHexDec :: MimaWord -> T.Text +shortValueToHexDec mw = shortValueToHex mw <> " (" <> shortValueToDec mw <> ")" + +signedShortValueToWord :: ShortValue -> MimaWord +signedShortValueToWord sv + | topBit sv = fromWord32 $ 0xFFFF0000 .|. toWord32 sv + | otherwise = fromWord32 $ toWord32 sv