From 9caa8298fccfdfbd1a1cc3c93d93dc03ad386846 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 12 Nov 2019 12:17:26 +0000 Subject: [PATCH] Add support for flags in execution --- app/MimaRun/Main.hs | 5 +- app/MimaRun/PrintState.hs | 2 +- src/Mima/Flag.hs | 136 ++++++++++++++++++++++++++++ src/Mima/State.hs | 181 ++++++++++++++++++++++---------------- 4 files changed, 244 insertions(+), 80 deletions(-) create mode 100644 src/Mima/Flag.hs diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs index 20048f8..e526bd5 100644 --- a/app/MimaRun/Main.hs +++ b/app/MimaRun/Main.hs @@ -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" diff --git a/app/MimaRun/PrintState.hs b/app/MimaRun/PrintState.hs index d3d7f3a..be0b573 100644 --- a/app/MimaRun/PrintState.hs +++ b/app/MimaRun/PrintState.hs @@ -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) diff --git a/src/Mima/Flag.hs b/src/Mima/Flag.hs new file mode 100644 index 0000000..530fcc3 --- /dev/null +++ b/src/Mima/Flag.hs @@ -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 + } diff --git a/src/Mima/State.hs b/src/Mima/State.hs index 7225692..974920c 100644 --- a/src/Mima/State.hs +++ b/src/Mima/State.hs @@ -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'