Add support for flags in execution

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"

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)
 

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
+  }

src/Mima/State.hs

@@ -2,19 +2,14 @@
 {-# LANGUAGE RecordWildCards #-}
 
 module Mima.State
-  (
+  ( MimaMemory
-  -- * Memory
-    MimaMemory
-  , readAt
-  , writeAt
-  -- ** Querying
-  , addressRange
-  , sparseAddressRange
-  -- ** Converting
   , 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 (InvalidInstruction t) = "Invalid instruction: " <> t
   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
+      then failWith InvalidNextIarAddress
-      else Right ms{msIAR = succ addr}
+      else pure ms{msIAR = succ addr}
 
-wordToInstruction' :: MimaWord -> Either AbortReason Instruction
+decodeInstruction :: MimaWord -> Execution Instruction
-wordToInstruction' word =
+decodeInstruction word =
   case wordToInstruction word of
-    Right instruction -> Right instruction
+    Right instruction -> pure instruction
-    Left errorMsg     -> Left $ InvalidInstruction errorMsg
+    Left errorMsg     -> failWith $ InvalidInstruction errorMsg
 
-step :: MimaState -> Either AbortReason MimaState
+storeValue :: MimaAddress -> MimaState -> Execution MimaState
-step ms = do
+storeValue addr ms = do
-  let word = readAt (msIAR ms) (msMemory ms)
+  flags <- ask
-  ms'         <- incrementIAR ms
+  if flagReadOnly flags addr
-  instruction <- wordToInstruction' word
+    then failWith AddressReadOnly
-  case instruction of
+    else pure ms{msMemory = writeAt addr (msACC ms) (msMemory ms)}
-    (SmallInstruction so lv) -> pure $ doSmallOpcode so lv ms'
-    (LargeInstruction lo sv) -> doLargeOpcode lo sv ms'
 
-doSmallOpcode :: SmallOpcode -> LargeValue -> MimaState -> MimaState
+loadValue :: MimaAddress -> MimaState -> Execution MimaState
-doSmallOpcode LDC  lv   ms@MimaState{..} = ms{msACC = largeValueToWord lv}
+loadValue addr ms = pure ms{msACC = readAt addr (msMemory ms)}
-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}
 
-doLargeOpcode :: LargeOpcode -> SmallValue -> MimaState -> Either AbortReason MimaState
+accOperation :: (MimaWord -> MimaWord -> MimaWord) -> MimaAddress -> MimaState -> Execution MimaState
-doLargeOpcode HALT _  _                = Left Halted
+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{..} =
+doLargeOpcode LDRS sv ms@MimaState{..} = loadValue (msSP + signedSmallValueToLargeValue sv) ms
-  let indirAddr = msSP + signedSmallValueToLargeValue sv
+doLargeOpcode STRS sv ms@MimaState{..} = storeValue (msSP + signedSmallValueToLargeValue sv) ms
-  in  pure ms{msACC = readAt indirAddr msMemory}
+doLargeOpcode LDRF sv ms@MimaState{..} = loadValue (msFP + signedSmallValueToLargeValue sv) ms
-doLargeOpcode STRS sv ms@MimaState{..} =
+doLargeOpcode STRF sv ms@MimaState{..} = storeValue (msFP + signedSmallValueToLargeValue sv) ms
-  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}
 
-run :: MimaState -> (MimaState, AbortReason, Integer)
+step :: MimaState -> Execution MimaState
-run ms = helper 0 ms
+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 :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
-runN n ms = helper 0 ms
+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'