Garmelon/mima-tools
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Use OddWords library

Browse source
This commit is contained in:
Joscha 2019-11-08 18:33:08 +00:00
parent 63a32ff01a
commit 112a49a7b7
5 changed files with 120 additions and 292 deletions
Download patch file Download diff file Expand all files Collapse all files

70
src/Mima/Instruction.hs
View file

@ -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)

15
src/Mima/Load.hs
View file

@ -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

47
src/Mima/State.hs
View file

@ -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

29
src/Mima/Util.hs
View file

@ -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

251
src/Mima/Word.hs
View file

@ -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