Add support for flags in execution
This commit is contained in:
parent
86f8b723b5
commit
9caa8298fc
4 changed files with 244 additions and 80 deletions
|
|
@ -4,6 +4,7 @@ import Control.Monad
|
|||
import qualified Data.Text.IO as T
|
||||
import Options.Applicative
|
||||
|
||||
import Mima.Flag
|
||||
import Mima.Load
|
||||
import Mima.State
|
||||
import Mima.Util
|
||||
|
|
@ -59,12 +60,12 @@ runMima settings s =
|
|||
case steps settings of
|
||||
Nothing -> do
|
||||
putStrLn "Running until HALT or execution exception..."
|
||||
let (s', e, x) = run s
|
||||
let (s', e, x) = run impotentChecks s
|
||||
putStrLn $ "Ran for " ++ show x ++ " steps"
|
||||
T.putStrLn $ toText e
|
||||
pure s'
|
||||
Just n -> do
|
||||
let (s', me, x) = runN n s
|
||||
let (s', me, x) = runN impotentChecks n s
|
||||
putStrLn $ "Ran for " ++ show x ++ " steps"
|
||||
case me of
|
||||
Nothing -> putStrLn "Encountered no exception"
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ printMemoryLocationLn addr word = do
|
|||
|
||||
printMemoryLn :: Bool -> MimaMemory -> IO ()
|
||||
printMemoryLn sparse mem = do
|
||||
let addresses = if sparse then sparseAddressRange mem else addressRange mem
|
||||
let addresses = if sparse then sparseUsedAddresses mem else usedAddresses mem
|
||||
forM_ addresses $ \addr -> do
|
||||
printMemoryLocationLn addr (readAt addr mem)
|
||||
|
||||
|
|
|
|||
136
src/Mima/Flag.hs
Normal file
136
src/Mima/Flag.hs
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Mima.Flag
|
||||
( AddressRange
|
||||
, lowerAddress
|
||||
, upperAddress
|
||||
, range
|
||||
, rangeToAddresses
|
||||
, rangeContains
|
||||
, simplifyRanges
|
||||
, AddressSpec
|
||||
, rangesToSpec
|
||||
, specToRanges
|
||||
, specNull
|
||||
, specContains
|
||||
, Flag(..)
|
||||
, allFlags
|
||||
, flagChar
|
||||
, Flags(..)
|
||||
, rawFlags
|
||||
, flagChecks
|
||||
, impotentChecks
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Mima.Word
|
||||
|
||||
data AddressRange = AddressRange
|
||||
{ lowerAddress :: MimaAddress
|
||||
, upperAddress :: MimaAddress
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
range :: MimaAddress -> MimaAddress -> AddressRange
|
||||
range a b
|
||||
| a <= b = AddressRange a b
|
||||
| otherwise = AddressRange b a
|
||||
|
||||
rangeToAddresses :: AddressRange -> [MimaAddress]
|
||||
rangeToAddresses r = [lowerAddress r..upperAddress r]
|
||||
|
||||
rangeContains :: AddressRange -> MimaAddress -> Bool
|
||||
rangeContains (AddressRange a b) c = a <= c && c <= b
|
||||
|
||||
simplifyRanges :: [AddressRange] -> [AddressRange]
|
||||
simplifyRanges = helper . sort
|
||||
where
|
||||
helper :: [AddressRange] -> [AddressRange]
|
||||
helper (r1:r2:rs)
|
||||
| upperAddress r1 >= lowerAddress r2 = helper (merge r1 r2 : rs)
|
||||
| otherwise = r1 : helper (r2:rs)
|
||||
helper a = a
|
||||
|
||||
merge :: AddressRange -> AddressRange -> AddressRange
|
||||
merge (AddressRange a1 b1) (AddressRange _ b2) = AddressRange a1 (max b1 b2)
|
||||
|
||||
|
||||
newtype AddressSpec = AddressSpec [AddressRange]
|
||||
deriving (Show)
|
||||
|
||||
rangesToSpec :: [AddressRange] -> AddressSpec
|
||||
rangesToSpec = AddressSpec . simplifyRanges
|
||||
|
||||
specToRanges :: AddressSpec -> [AddressRange]
|
||||
specToRanges (AddressSpec ranges) = ranges
|
||||
|
||||
specNull :: AddressSpec -> Bool
|
||||
specNull = null . specToRanges
|
||||
|
||||
specContains :: AddressSpec -> MimaAddress -> Bool
|
||||
specContains as addr = any (`rangeContains` addr) $ specToRanges as
|
||||
|
||||
{- Enough preamble, let's get to the flags -}
|
||||
|
||||
data Flag = Breakpoint | Executable | ReadOnly
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
allFlags :: [Flag]
|
||||
allFlags = [Breakpoint, Executable, ReadOnly]
|
||||
|
||||
flagChar :: Flag -> Char
|
||||
flagChar Breakpoint = 'b'
|
||||
flagChar Executable = 'e'
|
||||
flagChar ReadOnly = 'r'
|
||||
|
||||
data Flags a = Flags
|
||||
{ flagBreakpoint :: a
|
||||
, flagExecutable :: a
|
||||
, flagReadOnly :: a
|
||||
} deriving (Show)
|
||||
|
||||
instance Functor Flags where
|
||||
fmap f Flags{..} = Flags
|
||||
{ flagBreakpoint = f flagBreakpoint
|
||||
, flagExecutable = f flagExecutable
|
||||
, flagReadOnly = f flagReadOnly
|
||||
}
|
||||
|
||||
instance Applicative Flags where
|
||||
pure a = Flags a a a
|
||||
f <*> a = Flags
|
||||
{ flagBreakpoint = flagBreakpoint f $ flagBreakpoint a
|
||||
, flagExecutable = flagExecutable f $ flagExecutable a
|
||||
, flagReadOnly = flagReadOnly f $ flagReadOnly a
|
||||
}
|
||||
|
||||
rawFlags :: Flags Flag
|
||||
rawFlags = Flags
|
||||
{ flagBreakpoint = Breakpoint
|
||||
, flagExecutable = Executable
|
||||
, flagReadOnly = ReadOnly
|
||||
}
|
||||
|
||||
flagChecks :: Map.Map AddressRange (Set.Set Flag) -> Flags (MimaAddress -> Bool)
|
||||
flagChecks m =
|
||||
let getAddressSpec :: Flag -> AddressSpec
|
||||
getAddressSpec f = rangesToSpec $ map fst $ filter (Set.member f . snd) $ Map.assocs m
|
||||
|
||||
conditions :: Flags (AddressSpec -> MimaAddress -> Bool)
|
||||
conditions = Flags
|
||||
{ flagBreakpoint = specContains
|
||||
, flagExecutable = \as -> if specNull as then const True else specContains as
|
||||
, flagReadOnly = specContains
|
||||
}
|
||||
in conditions <*> (getAddressSpec <$> rawFlags)
|
||||
|
||||
-- | Flag checks that should not alter the behaviour of the MiMa.
|
||||
impotentChecks :: Flags (MimaAddress -> Bool)
|
||||
impotentChecks = Flags
|
||||
{ flagBreakpoint = const False
|
||||
, flagExecutable = const True
|
||||
, flagReadOnly = const False
|
||||
}
|
||||
|
|
@ -2,19 +2,14 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Mima.State
|
||||
(
|
||||
-- * Memory
|
||||
MimaMemory
|
||||
, readAt
|
||||
, writeAt
|
||||
-- ** Querying
|
||||
, addressRange
|
||||
, sparseAddressRange
|
||||
-- ** Converting
|
||||
( MimaMemory
|
||||
, mapToMemory
|
||||
, wordsToMemory
|
||||
, memoryToWords
|
||||
-- * State
|
||||
, usedAddresses
|
||||
, sparseUsedAddresses
|
||||
, readAt
|
||||
, writeAt
|
||||
, MimaState(..)
|
||||
, basicState
|
||||
, AbortReason(..)
|
||||
|
|
@ -23,10 +18,15 @@ module Mima.State
|
|||
, runN
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Bits
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Mima.Flag
|
||||
import Mima.Instruction
|
||||
import Mima.Util
|
||||
import Mima.Word
|
||||
|
|
@ -34,15 +34,6 @@ import Mima.Word
|
|||
newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord)
|
||||
deriving (Show)
|
||||
|
||||
addressRange :: MimaMemory -> [MimaAddress]
|
||||
addressRange (MimaMemory m) =
|
||||
case fst <$> Map.lookupMax m of
|
||||
Nothing -> []
|
||||
Just maxAddr -> [minBound..maxAddr]
|
||||
|
||||
sparseAddressRange :: MimaMemory -> [MimaAddress]
|
||||
sparseAddressRange (MimaMemory m) = Map.keys m
|
||||
|
||||
mapToMemory :: Map.Map MimaAddress MimaWord -> MimaMemory
|
||||
mapToMemory = MimaMemory . Map.filter (/= zeroBits)
|
||||
|
||||
|
|
@ -52,7 +43,16 @@ wordsToMemory = mapToMemory
|
|||
. zip [minBound..]
|
||||
|
||||
memoryToWords :: MimaMemory -> [MimaWord]
|
||||
memoryToWords mem = map (\addr -> readAt addr mem) $ addressRange mem
|
||||
memoryToWords mem = map (\addr -> readAt addr mem) $ usedAddresses mem
|
||||
|
||||
usedAddresses :: MimaMemory -> [MimaAddress]
|
||||
usedAddresses (MimaMemory m) =
|
||||
case fst <$> Map.lookupMax m of
|
||||
Nothing -> []
|
||||
Just maxAddr -> [minBound..maxAddr]
|
||||
|
||||
sparseUsedAddresses :: MimaMemory -> [MimaAddress]
|
||||
sparseUsedAddresses (MimaMemory m) = Map.keys m
|
||||
|
||||
readAt :: MimaAddress -> MimaMemory -> MimaWord
|
||||
readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m
|
||||
|
|
@ -74,58 +74,75 @@ data MimaState = MimaState
|
|||
basicState :: MimaMemory -> MimaState
|
||||
basicState = MimaState zeroBits zeroBits zeroBits zeroBits zeroBits
|
||||
|
||||
data AbortReason = Halted | InvalidInstruction T.Text | InvalidNextIarAddress
|
||||
data AbortReason
|
||||
= Halted
|
||||
| InvalidInstruction T.Text
|
||||
| InvalidNextIarAddress
|
||||
| AddressNotExecutable
|
||||
| AddressReadOnly
|
||||
deriving (Show)
|
||||
|
||||
instance ToText AbortReason where
|
||||
toText Halted = "Halted"
|
||||
toText Halted = "Halted"
|
||||
toText (InvalidInstruction t) = "Invalid instruction: " <> t
|
||||
toText InvalidNextIarAddress = "Can't increment IAR: Invalid next address"
|
||||
toText InvalidNextIarAddress = "Can't increment IAR: Invalid next address"
|
||||
toText AddressNotExecutable = "Address is not flagged as excutable"
|
||||
toText AddressReadOnly = "Address is flagged as read-only"
|
||||
|
||||
incrementIAR :: MimaState -> Either AbortReason MimaState
|
||||
{- A fancy monad that helps with stepping the MimaState -}
|
||||
|
||||
type Execution a = ReaderT (Flags (MimaAddress -> Bool)) (Except AbortReason) a
|
||||
|
||||
runExecution :: Flags (MimaAddress -> Bool) -> Execution a -> Either AbortReason a
|
||||
runExecution f exec = runExcept $ runReaderT exec f
|
||||
|
||||
failWith :: AbortReason -> Execution a
|
||||
failWith = lift . except . Left
|
||||
|
||||
incrementIAR :: MimaState -> Execution MimaState
|
||||
incrementIAR ms =
|
||||
let addr = msIAR ms
|
||||
in if addr >= maxBound
|
||||
then Left InvalidNextIarAddress
|
||||
else Right ms{msIAR = succ addr}
|
||||
then failWith InvalidNextIarAddress
|
||||
else pure ms{msIAR = succ addr}
|
||||
|
||||
wordToInstruction' :: MimaWord -> Either AbortReason Instruction
|
||||
wordToInstruction' word =
|
||||
decodeInstruction :: MimaWord -> Execution Instruction
|
||||
decodeInstruction word =
|
||||
case wordToInstruction word of
|
||||
Right instruction -> Right instruction
|
||||
Left errorMsg -> Left $ InvalidInstruction errorMsg
|
||||
Right instruction -> pure instruction
|
||||
Left errorMsg -> failWith $ InvalidInstruction errorMsg
|
||||
|
||||
step :: MimaState -> Either AbortReason MimaState
|
||||
step ms = do
|
||||
let word = readAt (msIAR ms) (msMemory ms)
|
||||
ms' <- incrementIAR ms
|
||||
instruction <- wordToInstruction' word
|
||||
case instruction of
|
||||
(SmallInstruction so lv) -> pure $ doSmallOpcode so lv ms'
|
||||
(LargeInstruction lo sv) -> doLargeOpcode lo sv ms'
|
||||
storeValue :: MimaAddress -> MimaState -> Execution MimaState
|
||||
storeValue addr ms = do
|
||||
flags <- ask
|
||||
if flagReadOnly flags addr
|
||||
then failWith AddressReadOnly
|
||||
else pure ms{msMemory = writeAt addr (msACC ms) (msMemory ms)}
|
||||
|
||||
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 = 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}
|
||||
doSmallOpcode EQL addr ms@MimaState{..} = ms{msACC = boolToWord $ msACC == readAt addr msMemory}
|
||||
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 = getLargeValue $ readAt addr msMemory
|
||||
in ms{msACC = readAt indirAddr msMemory}
|
||||
doSmallOpcode STIV addr ms@MimaState{..} =
|
||||
let indirAddr = getLargeValue $ readAt addr msMemory
|
||||
in ms{msMemory = writeAt indirAddr msACC msMemory}
|
||||
doSmallOpcode CALL addr ms@MimaState{..} = ms{msRA = msIAR, msIAR = addr}
|
||||
doSmallOpcode ADC lv ms@MimaState{..} = ms{msACC = msACC + signedLargeValueToWord lv}
|
||||
loadValue :: MimaAddress -> MimaState -> Execution MimaState
|
||||
loadValue addr ms = pure ms{msACC = readAt addr (msMemory ms)}
|
||||
|
||||
doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Either AbortReason MimaState
|
||||
doLargeOpcode HALT _ _ = Left Halted
|
||||
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 _ _ = failWith 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}
|
||||
|
|
@ -135,33 +152,43 @@ 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{..} =
|
||||
let indirAddr = msSP + signedSmallValueToLargeValue sv
|
||||
in pure ms{msACC = readAt indirAddr msMemory}
|
||||
doLargeOpcode STRS sv ms@MimaState{..} =
|
||||
let indirAddr = msSP + signedSmallValueToLargeValue sv
|
||||
in pure ms{msMemory = writeAt indirAddr msACC msMemory}
|
||||
doLargeOpcode LDRF sv ms@MimaState{..} =
|
||||
let indirAddr = msFP + signedSmallValueToLargeValue sv
|
||||
in pure ms{msACC = readAt indirAddr msMemory}
|
||||
doLargeOpcode STRF sv ms@MimaState{..} =
|
||||
let indirAddr = msFP + signedSmallValueToLargeValue sv
|
||||
in pure ms{msMemory = writeAt indirAddr msACC msMemory}
|
||||
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
|
||||
|
||||
run :: MimaState -> (MimaState, AbortReason, Integer)
|
||||
run ms = helper 0 ms
|
||||
step :: MimaState -> Execution MimaState
|
||||
step ms = do
|
||||
let addr = msIAR ms
|
||||
flags <- ask
|
||||
unless (flagExecutable flags addr) $ failWith AddressNotExecutable
|
||||
|
||||
let 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'
|
||||
|
||||
step' :: Flags (MimaAddress -> Bool) -> MimaState -> Either AbortReason MimaState
|
||||
step' flags ms = runExecution flags $ step ms
|
||||
|
||||
run :: Flags (MimaAddress -> Bool) -> MimaState -> (MimaState, AbortReason, Integer)
|
||||
run f ms = helper 0 ms
|
||||
where
|
||||
helper completed s =
|
||||
case step s of
|
||||
case step' f s of
|
||||
Left e -> (s, e, completed)
|
||||
Right s' -> helper (completed + 1) s'
|
||||
|
||||
runN :: Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
|
||||
runN n ms = helper 0 ms
|
||||
runN :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
|
||||
runN f n ms = helper 0 ms
|
||||
where
|
||||
helper completed s =
|
||||
if completed >= n
|
||||
then (s, Nothing, completed)
|
||||
else case step s of
|
||||
else case step' f s of
|
||||
Left e -> (s, Just e, completed)
|
||||
Right s' -> helper (completed + 1) s'
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue