Begin rewrite
... by deleting most files. By the theory of evolution, the remaining ones will get stronger over the next commits. That's how it works, isn't it?
This commit is contained in:
parent
3e0f4e22b1
commit
b1274d5d2c
37 changed files with 218 additions and 2424 deletions
128
src/Mima/Vm/Instruction.hs
Normal file
128
src/Mima/Vm/Instruction.hs
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Mima.Vm.Instruction
|
||||
( SmallOpcode(..)
|
||||
, LargeOpcode(..)
|
||||
, argumentIsOptional
|
||||
, Instruction(..)
|
||||
, wordToInstruction
|
||||
, instructionToWord
|
||||
) where
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Mima.Format
|
||||
import Mima.Vm.Word
|
||||
|
||||
data SmallOpcode = LDC | LDV | STV | ADD | AND | OR | XOR | EQL
|
||||
| JMP | JMN | LDIV | STIV | CALL | ADC
|
||||
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, LDIV, STIV, CALL, ADC]
|
||||
|
||||
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 ADC = 13
|
||||
|
||||
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 | LDRS | STRS | LDRF | STRF
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
instance ToText LargeOpcode where
|
||||
toText = T.pack . show
|
||||
|
||||
allLargeOpcodes :: [LargeOpcode]
|
||||
allLargeOpcodes = [HALT, NOT, RAR, RET, LDRA, STRA, LDSP, STSP,
|
||||
LDFP, STFP, LDRS, STRS, LDRF, STRF]
|
||||
|
||||
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 LDRS = 10
|
||||
largeOpcodeNr STRS = 11
|
||||
largeOpcodeNr LDRF = 12
|
||||
largeOpcodeNr STRF = 13
|
||||
|
||||
largeOpcodeMap :: Map.Map Opcode LargeOpcode
|
||||
largeOpcodeMap = Map.fromList [(largeOpcodeNr lo, lo) | lo <- allLargeOpcodes]
|
||||
|
||||
argumentIsOptional :: LargeOpcode -> Bool
|
||||
argumentIsOptional HALT = True
|
||||
argumentIsOptional NOT = True
|
||||
argumentIsOptional RAR = True
|
||||
argumentIsOptional RET = True
|
||||
argumentIsOptional LDRA = True
|
||||
argumentIsOptional STRA = True
|
||||
argumentIsOptional LDSP = True
|
||||
argumentIsOptional STSP = True
|
||||
argumentIsOptional LDFP = True
|
||||
argumentIsOptional STFP = True
|
||||
argumentIsOptional LDRS = False
|
||||
argumentIsOptional STRS = False
|
||||
argumentIsOptional LDRF = False
|
||||
argumentIsOptional STRF = False
|
||||
|
||||
data Instruction
|
||||
= SmallInstruction !SmallOpcode !LargeValue
|
||||
| LargeInstruction !LargeOpcode !SmallValue
|
||||
deriving (Show, Eq)
|
||||
|
||||
wordToInstruction :: MimaWord -> Either T.Text Instruction
|
||||
wordToInstruction mw = if getSmallOpcode mw == 0xF
|
||||
then parseLargeInstruction mw
|
||||
else parseSmallInstruction mw
|
||||
|
||||
parseSmallInstruction :: MimaWord -> Either T.Text Instruction
|
||||
parseSmallInstruction mw = do
|
||||
so <- parseSmallOpcode (getSmallOpcode mw)
|
||||
pure $ SmallInstruction so (getLargeValue mw)
|
||||
|
||||
parseSmallOpcode :: Opcode -> Either T.Text SmallOpcode
|
||||
parseSmallOpcode w = case smallOpcodeMap Map.!? w of
|
||||
Just oc -> pure oc
|
||||
Nothing -> Left $ "Unknown small opcode " <> toDec w <> " (" <> fixWidthHex 1 (toHex w)
|
||||
<> ", " <> fixWidthBin 4 (toBin w) <> ")"
|
||||
|
||||
parseLargeInstruction :: MimaWord -> Either T.Text Instruction
|
||||
parseLargeInstruction mw = do
|
||||
lo <- parseLargeOpcode (getLargeOpcode mw)
|
||||
pure $ LargeInstruction lo (getSmallValue mw)
|
||||
|
||||
parseLargeOpcode :: Opcode -> Either T.Text LargeOpcode
|
||||
parseLargeOpcode w = case largeOpcodeMap Map.!? w of
|
||||
Just oc -> pure oc
|
||||
Nothing -> Left $ "Unknown large opcode " <> toDec w <> " (" <> fixWidthHex 1 (toHex w)
|
||||
<> ", " <> fixWidthBin 4 (toBin w) <> ")"
|
||||
|
||||
instructionToWord :: Instruction -> MimaWord
|
||||
instructionToWord (SmallInstruction so lv) = wordFromSmallOpcode (smallOpcodeNr so) lv
|
||||
instructionToWord (LargeInstruction lo sv) = wordFromLargeOpcode (largeOpcodeNr lo) sv
|
||||
47
src/Mima/Vm/Memory.hs
Normal file
47
src/Mima/Vm/Memory.hs
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
module Mima.Vm.Memory
|
||||
( MimaMemory
|
||||
, mapToMemory
|
||||
, wordsToMemory
|
||||
, memoryToWords
|
||||
, maxAddress
|
||||
, usedAddresses
|
||||
, continuousUsedAddresses
|
||||
, readAt
|
||||
, writeAt
|
||||
) where
|
||||
|
||||
import Data.Bits
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Mima.Vm.Word
|
||||
|
||||
newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord)
|
||||
deriving (Show)
|
||||
|
||||
mapToMemory :: Map.Map MimaAddress MimaWord -> MimaMemory
|
||||
mapToMemory = MimaMemory . Map.filter (/= zeroBits)
|
||||
|
||||
wordsToMemory :: [MimaWord] -> MimaMemory
|
||||
wordsToMemory = mapToMemory
|
||||
. Map.fromAscList
|
||||
. zip [minBound..]
|
||||
|
||||
memoryToWords :: MimaMemory -> [MimaWord]
|
||||
memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem
|
||||
|
||||
maxAddress :: MimaMemory -> MimaAddress
|
||||
maxAddress (MimaMemory m) = maybe minBound fst $ Map.lookupMax m
|
||||
|
||||
usedAddresses :: MimaMemory -> [MimaAddress]
|
||||
usedAddresses (MimaMemory m) = Map.keys m
|
||||
|
||||
continuousUsedAddresses :: MimaMemory -> [MimaAddress]
|
||||
continuousUsedAddresses mem = [minBound..maxAddress mem]
|
||||
|
||||
readAt :: MimaAddress -> MimaMemory -> MimaWord
|
||||
readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m
|
||||
|
||||
writeAt :: MimaAddress -> MimaWord -> MimaMemory -> MimaMemory
|
||||
writeAt addr word (MimaMemory m)
|
||||
| word == zeroBits = MimaMemory $ Map.delete addr m
|
||||
| otherwise = MimaMemory $ Map.insert addr word m
|
||||
132
src/Mima/Vm/State.hs
Normal file
132
src/Mima/Vm/State.hs
Normal file
|
|
@ -0,0 +1,132 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Mima.Vm.State
|
||||
( MimaState(..)
|
||||
, basicState
|
||||
, AbortReason(..)
|
||||
, step
|
||||
, run
|
||||
, runN
|
||||
) where
|
||||
|
||||
import Data.Bits
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Mima.Format
|
||||
import Mima.Vm.Instruction
|
||||
import Mima.Vm.Memory
|
||||
import Mima.Vm.Word
|
||||
|
||||
data MimaState = MimaState
|
||||
{ msIar :: !MimaAddress
|
||||
, msAcc :: !MimaWord
|
||||
, msRa :: !MimaAddress
|
||||
, msSp :: !MimaAddress
|
||||
, msFp :: !MimaAddress
|
||||
, msMemory :: !MimaMemory
|
||||
} deriving (Show)
|
||||
|
||||
basicState :: MimaMemory -> MimaState
|
||||
basicState = MimaState zeroBits zeroBits zeroBits zeroBits zeroBits
|
||||
|
||||
data AbortReason
|
||||
= Halted
|
||||
| InvalidInstruction T.Text
|
||||
| InvalidNextIarAddress
|
||||
| AddressNotExecutable
|
||||
| AddressReadOnly
|
||||
deriving (Show)
|
||||
|
||||
instance ToText AbortReason where
|
||||
toText Halted = "Halted"
|
||||
toText (InvalidInstruction t) = "Exception: Invalid instruction: " <> t
|
||||
toText InvalidNextIarAddress = "Exception: Can't increment IAR: Invalid next address"
|
||||
toText AddressNotExecutable = "Exception: Address is not flagged as excutable"
|
||||
toText AddressReadOnly = "Exception: Address is flagged as read-only"
|
||||
|
||||
{- A fancy monad that helps with stepping the MimaState -}
|
||||
|
||||
type Execution a = Either AbortReason a
|
||||
|
||||
incrementIar :: MimaState -> Execution MimaState
|
||||
incrementIar ms
|
||||
| addr >= maxBound = Left InvalidNextIarAddress
|
||||
| otherwise = pure ms{msIar = succ addr}
|
||||
where
|
||||
addr = msIar ms
|
||||
|
||||
decodeInstruction :: MimaWord -> Execution Instruction
|
||||
decodeInstruction word =
|
||||
case wordToInstruction word of
|
||||
Right instruction -> pure instruction
|
||||
Left errorMsg -> Left $ InvalidInstruction errorMsg
|
||||
|
||||
storeValue :: MimaAddress -> MimaState -> Execution MimaState
|
||||
storeValue addr ms = pure ms{msMemory = writeAt addr (msAcc ms) (msMemory ms)}
|
||||
|
||||
loadValue :: MimaAddress -> MimaState -> Execution MimaState
|
||||
loadValue addr ms = pure ms{msAcc = readAt addr (msMemory ms)}
|
||||
|
||||
accOperation :: (MimaWord -> MimaWord -> MimaWord) -> MimaAddress -> MimaState -> Execution MimaState
|
||||
accOperation f addr ms = pure ms{msAcc = f (msAcc ms) $ readAt addr (msMemory ms)}
|
||||
|
||||
doSmallOpcode :: SmallOpcode -> LargeValue -> MimaState -> Execution MimaState
|
||||
doSmallOpcode LDC lv ms@MimaState{..} = pure ms{msAcc = largeValueToWord lv}
|
||||
doSmallOpcode LDV addr ms = loadValue addr ms
|
||||
doSmallOpcode STV addr ms = storeValue addr ms
|
||||
doSmallOpcode ADD addr ms@MimaState{..} = accOperation (+) addr ms
|
||||
doSmallOpcode AND addr ms@MimaState{..} = accOperation (.&.) addr ms
|
||||
doSmallOpcode OR addr ms@MimaState{..} = accOperation (.|.) addr ms
|
||||
doSmallOpcode XOR addr ms@MimaState{..} = accOperation xor addr ms
|
||||
doSmallOpcode EQL addr ms@MimaState{..} = accOperation (\a b -> boolToWord $ a == b) addr ms
|
||||
doSmallOpcode JMP addr ms@MimaState{..} = pure ms{msIar = addr}
|
||||
doSmallOpcode JMN addr ms@MimaState{..} = pure $ if topBit msAcc then ms{msIar = addr} else ms
|
||||
doSmallOpcode LDIV addr ms@MimaState{..} = loadValue (getLargeValue $ readAt addr msMemory) ms
|
||||
doSmallOpcode STIV addr ms@MimaState{..} = storeValue (getLargeValue $ readAt addr msMemory) ms
|
||||
doSmallOpcode CALL addr ms@MimaState{..} = pure ms{msRa = msIar, msIar = addr}
|
||||
doSmallOpcode ADC lv ms@MimaState{..} = pure ms{msAcc = msAcc + signedLargeValueToWord lv}
|
||||
|
||||
doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Execution MimaState
|
||||
doLargeOpcode HALT _ _ = Left Halted
|
||||
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 = getLargeValue msAcc}
|
||||
doLargeOpcode LDSP _ ms@MimaState{..} = pure ms{msAcc = largeValueToWord msSp}
|
||||
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 = getLargeValue msAcc}
|
||||
doLargeOpcode LDRS sv ms@MimaState{..} = loadValue (msSp + signedSmallValueToLargeValue sv) ms
|
||||
doLargeOpcode STRS sv ms@MimaState{..} = storeValue (msSp + signedSmallValueToLargeValue sv) ms
|
||||
doLargeOpcode LDRF sv ms@MimaState{..} = loadValue (msFp + signedSmallValueToLargeValue sv) ms
|
||||
doLargeOpcode STRF sv ms@MimaState{..} = storeValue (msFp + signedSmallValueToLargeValue sv) ms
|
||||
|
||||
step :: MimaState -> Execution MimaState
|
||||
step ms = do
|
||||
let addr = msIar ms
|
||||
word = readAt addr (msMemory ms)
|
||||
instruction <- decodeInstruction word
|
||||
ms' <- incrementIar ms
|
||||
case instruction of
|
||||
(SmallInstruction so lv) -> doSmallOpcode so lv ms'
|
||||
(LargeInstruction lo sv) -> doLargeOpcode lo sv ms'
|
||||
|
||||
run :: MimaState -> (MimaState, AbortReason, Integer)
|
||||
run = helper 0
|
||||
where
|
||||
helper completed s =
|
||||
case step s of
|
||||
Left e -> (s, e, completed)
|
||||
Right s' -> helper (completed + 1) s'
|
||||
|
||||
runN :: Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
|
||||
runN n = helper 0
|
||||
where
|
||||
helper completed s =
|
||||
if completed >= n
|
||||
then (s, Nothing, completed)
|
||||
else case step s of
|
||||
Left e -> (s, Just e, completed)
|
||||
Right s' -> helper (completed + 1) s'
|
||||
86
src/Mima/Vm/Word.hs
Normal file
86
src/Mima/Vm/Word.hs
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
module Mima.Vm.Word
|
||||
(
|
||||
-- * Types
|
||||
MimaWord
|
||||
, MimaAddress
|
||||
, LargeValue
|
||||
, SmallValue
|
||||
, Opcode
|
||||
, topBit
|
||||
-- * Converting between types
|
||||
, bytesToWord
|
||||
, wordToBytes
|
||||
, boolToWord
|
||||
, largeValueToWord
|
||||
, signedLargeValueToWord
|
||||
, signedSmallValueToLargeValue
|
||||
, wordFromSmallOpcode
|
||||
, wordFromLargeOpcode
|
||||
-- ** 'MimaWord' properties
|
||||
, getSmallOpcode
|
||||
, getLargeOpcode
|
||||
, getLargeValue
|
||||
, getSmallValue
|
||||
) where
|
||||
|
||||
import Data.Bits
|
||||
import Data.Word
|
||||
import Data.Word.Odd
|
||||
|
||||
type MimaWord = Word24
|
||||
type MimaAddress = LargeValue
|
||||
type LargeValue = Word20
|
||||
type SmallValue = Word16
|
||||
type Opcode = Word4
|
||||
|
||||
topBit :: (FiniteBits b) => b -> Bool
|
||||
topBit b = testBit b $ finiteBitSize b - 1
|
||||
|
||||
bytesToWord :: (Word8, Word8, Word8) -> MimaWord
|
||||
bytesToWord (w1, w2, w3) =
|
||||
let (w1', w2', w3') = (fromIntegral w1, fromIntegral w2, fromIntegral w3)
|
||||
in shiftL w1' 16 .|. shiftL w2' 8 .|. w3'
|
||||
|
||||
wordToBytes :: MimaWord -> (Word8, Word8, Word8)
|
||||
wordToBytes mw =
|
||||
-- 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
|
||||
|
||||
largeValueToWord :: LargeValue -> MimaWord
|
||||
largeValueToWord = fromIntegral
|
||||
|
||||
signedLargeValueToWord :: LargeValue -> MimaWord
|
||||
signedLargeValueToWord lv
|
||||
| topBit lv = 0xF00000 .|. fromIntegral lv
|
||||
| otherwise = fromIntegral lv
|
||||
|
||||
signedSmallValueToLargeValue :: SmallValue -> LargeValue
|
||||
signedSmallValueToLargeValue sv
|
||||
| topBit sv = 0xF0000 .|. fromIntegral sv
|
||||
| otherwise = fromIntegral sv
|
||||
|
||||
wordFromSmallOpcode :: Opcode -> LargeValue -> MimaWord
|
||||
wordFromSmallOpcode so lv = shiftL (fromIntegral so) 20 .|. fromIntegral lv
|
||||
|
||||
wordFromLargeOpcode :: Opcode -> SmallValue -> MimaWord
|
||||
wordFromLargeOpcode lo sv = 0xF00000 .|. shiftL (fromIntegral lo) 16 .|. 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue