diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs index 692d09c..432359b 100644 --- a/app/MimaRun/Main.hs +++ b/app/MimaRun/Main.hs @@ -146,7 +146,7 @@ main :: IO () main = doRun_ $ do settings <- lift $ execParser opts - lift $ putStrLn $ "Loading memdump at " ++ infile settings + lift $ putStrLn $ "Loading memdump from " ++ infile settings ms <- loadStateFromFile (infile settings) flags <- loadFlags settings @@ -156,7 +156,7 @@ main = doRun_ $ do then pure ms else lift $ runMima settings ms flags - unless (quiet settings) $ printState ms flags labels settings + unless (quiet settings) $ printState ms' flags labels settings forM_ (outfile settings) $ \path -> do lift $ putStrLn $ "Saving memdump at " ++ path diff --git a/app/MimaRun/PrintState.hs b/app/MimaRun/PrintState.hs deleted file mode 100644 index 40aadc6..0000000 --- a/app/MimaRun/PrintState.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - -module PrintState - ( printStateLn - ) where - -import Control.Monad -import Data.Bits -import qualified Data.Text as T -import qualified Data.Text.IO as T -import System.Console.ANSI - -import Mima.Format.Common -import Mima.Instruction -import Mima.State -import Mima.Util -import Mima.Word - -printAddress :: Int -> MimaAddress -> IO () -printAddress n addr = do - T.putStr $ toHex addr - putStr " (" - T.putStr $ T.justifyRight n ' ' $ toDec addr - putStr ")" - -printWord :: Int -> MimaWord -> IO () -printWord n word = do - T.putStr $ toHex word - putStr " (" - T.putStr $ T.justifyRight n ' ' $ toDec word - putStr ")" - --- Color scheme: --- Red: HALT --- Yellow: Instructions for accessing other registers --- Green: Instructions that can modify the IAR (jumps) --- Blue: Instructions that read from or write to memory --- Cyan: Logical operations and calculations that modify the ACC -printInstruction :: Instruction -> IO () -printInstruction (SmallInstruction so lv) = do - setSGR [SetConsoleIntensity BoldIntensity] - if | so `elem` [JMP, JMN, CALL] -> setSGR [SetColor Foreground Dull Green] - | so `elem` [LDC, LDV, STV, LDIV, STIV] -> setSGR [SetColor Foreground Vivid Blue] - | so `elem` [ADD, AND, OR, XOR, EQL, ADC] -> setSGR [SetColor Foreground Vivid Cyan] - | otherwise -> pure () - T.putStr $ toText so - putStr " " - setSGR [SetColor Foreground Vivid Black] - T.putStr $ toDec lv - setSGR [] -printInstruction (LargeInstruction lo sv) = do - setSGR [SetConsoleIntensity BoldIntensity] - if | lo == HALT -> setSGR [SetColor Foreground Vivid Red] - | lo `elem` [LDRA, STRA, LDSP, STSP, LDFP, STFP] -> setSGR [SetColor Foreground Dull Yellow] - | lo == RET -> setSGR [SetColor Foreground Dull Green] - | lo `elem` [LDRS, STRS, LDRF, STRF] -> setSGR [SetColor Foreground Vivid Blue] - | lo `elem` [NOT, RAR] -> setSGR [SetColor Foreground Vivid Cyan] - | otherwise -> pure () - T.putStr $ toText lo - when (lo `elem` [LDRS, STRS, LDRF, STRF] || sv /= zeroBits) $ do - putStr " " - setSGR [SetColor Foreground Vivid Black] - T.putStr $ toDec sv - setSGR [] - -printWordWithInstruction :: Int -> MimaWord -> IO () -printWordWithInstruction n word = do - printWord n word - case wordToInstruction word of - Left _ -> pure () - Right i -> do - putStr ": " - printInstruction i - -printAddressRegister :: MimaState -> MimaAddress -> IO () -printAddressRegister ms addr = do - printAddress 8 addr - putStr " -> " - printWordWithInstruction 8 $ readAt addr $ msMemory ms - -printRegistersLn :: MimaState -> IO () -printRegistersLn ms = do - putStr "IAR: " - printAddressRegister ms $ msIAR ms - putStrLn "" - - putStr "ACC: " - printWord 8 $ msACC ms - putStrLn "" - - putStr " RA: " - printAddressRegister ms $ msRA ms - putStrLn "" - - putStr " SP: " - printAddressRegister ms $ msSP ms - putStrLn "" - - putStr " FP: " - printAddressRegister ms $ msFP ms - putStrLn "" - -printMemoryLocationLn :: MimaAddress -> MimaWord -> IO () -printMemoryLocationLn addr word = do - printAddress 7 addr - putStr " -> " - printWord 8 word - case wordToInstruction word of - Left _ -> pure () - Right i -> do - putStr ": " - printInstruction i - putStrLn "" - -printMemoryLn :: Bool -> MimaMemory -> IO () -printMemoryLn sparse mem = do - let addresses = if sparse then sparseUsedAddresses mem else usedAddresses mem - forM_ addresses $ \addr -> do - printMemoryLocationLn addr (readAt addr mem) - -printStateLn :: Bool -> MimaState -> IO () -printStateLn sparse ms = do - printRegistersLn ms - printMemoryLn sparse $ msMemory ms diff --git a/src/Mima/Format/State.hs b/src/Mima/Format/State.hs index c4d1f7b..0da1b24 100644 --- a/src/Mima/Format/State.hs +++ b/src/Mima/Format/State.hs @@ -13,6 +13,10 @@ module Mima.Format.State , fAddress -- * Words , fWord + -- * Memory + , fMemory + -- * Registers + , fRegisters -- * The whole state , formatState ) where @@ -30,8 +34,9 @@ import Mima.Word data FormatConfig = FormatConfig { fcSparse :: Bool - , fcShowRegisterFlags :: Bool + , fcShowRegisters :: Bool , fcShowMemoryFlags :: Bool + , fcShowRegisterFlags :: Bool , fcShowAddressDec :: Bool , fcShowAddressHex :: Bool , fcShowAddressBin :: Bool @@ -108,7 +113,7 @@ fAddress a = do hex = if fcShowAddressHex conf then [fAddressHex] else [] bin = if fcShowAddressBin conf then [fAddressBin] else [] formats = (dec ++ hex ++ bin) <*> pure a - pure $ "[" <> T.intercalate "," formats <> "]" + pure $ "[" <> T.intercalate ", " formats <> "]" {- Words -} @@ -129,7 +134,7 @@ fWord a = do hex = if fcShowWordHex conf then [fWordHex] else [] bin = if fcShowWordBin conf then [fWordBin] else [] formats = (dec ++ hex ++ bin) <*> pure a - pure $ "{" <> T.intercalate "," formats <> "}" + pure $ "{" <> T.intercalate ", " formats <> "}" {- Memory -} @@ -143,18 +148,65 @@ fMemoryLn a = do word <- fWord w pure $ flags <> " " <> addr <> " " <> word <> "\n" -fMemory :: Formatter -fMemory = do +interestingAddresses :: FormatReader (Set.Set MimaAddress) +interestingAddresses = do + env <- ask + let conf = feConf env + s = feState env + pure $ if fcShowRegisterFlags conf + then Set.fromList [msIAR s, msRA s, msSP s, msFP s] + else Set.empty + +getAddresses :: FormatReader [MimaAddress] +getAddresses = do env <- ask let conf = feConf env mem = msMemory $ feState env - addrs = if fcSparse conf then sparseUsedAddresses mem else usedAddresses mem + if fcSparse conf + then do + interesting <- interestingAddresses + pure $ Set.toAscList $ Set.union interesting $ Set.fromList $ usedAddresses mem + else pure $ usedAddresses mem + +fMemory :: Formatter +fMemory = do + addrs <- getAddresses mconcat <$> mapM fMemoryLn addrs +{- Registers -} + +fAddressRegister :: T.Text -> MimaAddress -> Formatter +fAddressRegister name addr = do + addrText <- fAddress addr + pure $ name <> ": " <> addrText <> "\n" + +fWordRegister :: T.Text -> MimaWord -> Formatter +fWordRegister name word = do + wordText <- fWord word + pure $ name <> ": " <> wordText <> "\n" + +fRegisters :: Formatter +fRegisters = do + env <- ask + let s = feState env + mconcat <$> sequenceA [ fAddressRegister "IAR" (msIAR s) + , fWordRegister "ACC" (msACC s) + , fAddressRegister " RA" (msRA s) + , fAddressRegister " SP" (msSP s) + , fAddressRegister " FP" (msFP s) + ] + {- And finally, the whole state -} fState :: Formatter -fState = fMemory +fState = do + env <- ask + let conf = feConf env + memText <- ("--< MEMORY >--\n" <>) <$> fMemory + regText <- ("--< REGISTERS >--\n" <>) <$> fRegisters + pure $ if fcShowRegisters conf + then regText <> memText + else memText formatState :: FormatEnv -> T.Text formatState = runReader fState diff --git a/src/Mima/Options.hs b/src/Mima/Options.hs index ae41c20..36a00ee 100644 --- a/src/Mima/Options.hs +++ b/src/Mima/Options.hs @@ -36,10 +36,12 @@ formatConfigParser :: Parser FormatConfig formatConfigParser = FormatConfig <$> hiddenSwitchWithNo "sparse" True "Omit uninteresting addresses" + <*> hiddenSwitchWithNo "registers" True + "Show the contents of registers before the memory dump" + <*> hiddenSwitchWithNo "memory-flags" False + "For each address, show all registers currently pointing to that address" <*> hiddenSwitchWithNo "register-flags" True "For each address, show all the memory flags that are active for that address" - <*> hiddenSwitchWithNo "memory-flags" True - "For each address, show all registers currently pointing to that address" <*> hiddenSwitchWithNo "address-dec" True "Display addresses in decimal" <*> hiddenSwitchWithNo "address-hex" True diff --git a/src/Mima/State.hs b/src/Mima/State.hs index b94cd98..87f1d2f 100644 --- a/src/Mima/State.hs +++ b/src/Mima/State.hs @@ -6,8 +6,9 @@ module Mima.State , mapToMemory , wordsToMemory , memoryToWords + , maxAddress , usedAddresses - , sparseUsedAddresses + , continuousUsedAddresses , readAt , writeAt , MimaState(..) @@ -24,6 +25,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Data.Bits import qualified Data.Map.Strict as Map +import Data.Maybe import qualified Data.Text as T import Mima.Flag @@ -43,16 +45,16 @@ wordsToMemory = mapToMemory . zip [minBound..] memoryToWords :: MimaMemory -> [MimaWord] -memoryToWords mem = map (\addr -> readAt addr mem) $ usedAddresses mem +memoryToWords mem = map (\addr -> readAt addr mem) $ continuousUsedAddresses mem + +maxAddress :: MimaMemory -> MimaAddress +maxAddress (MimaMemory m) = fromMaybe minBound $ fst <$> Map.lookupMax m usedAddresses :: MimaMemory -> [MimaAddress] -usedAddresses (MimaMemory m) = - case fst <$> Map.lookupMax m of - Nothing -> [] - Just maxAddr -> [minBound..maxAddr] +usedAddresses (MimaMemory m) = Map.keys m -sparseUsedAddresses :: MimaMemory -> [MimaAddress] -sparseUsedAddresses (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