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.
This commit is contained in:
parent
a454890dac
commit
3eb9430208
1 changed files with 167 additions and 98 deletions
265
src/Mima/Word.hs
265
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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue