From 8bfce48a7f16c0aff4a0a8daea9738bb9d4a0869 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 19 Nov 2019 10:24:53 +0000 Subject: [PATCH] Format mima state Also, use the new formatter in mima-run (and while we're at it, clean up flag file loading and prepare for symbol file loading). --- app/MimaRun/Main.hs | 104 ++++++++++++++--------- src/Mima/Format/State.hs | 176 +++++++++++++++++++++++++++++++++++++++ src/Mima/Label.hs | 6 +- src/Mima/Options.hs | 28 +++++++ 4 files changed, 273 insertions(+), 41 deletions(-) create mode 100644 src/Mima/Format/State.hs create mode 100644 src/Mima/Options.hs diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs index e825ad9..7c3259e 100644 --- a/app/MimaRun/Main.hs +++ b/app/MimaRun/Main.hs @@ -2,20 +2,22 @@ module Main where import Control.Monad import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import qualified Data.Text.IO as T import Options.Applicative import System.FilePath import Mima.Flag +import Mima.Format.State import Mima.IO +import Mima.Label import Mima.Load +import Mima.Options import Mima.Parse.FlagFile import Mima.State import Mima.Util import Mima.Word -import PrintState - data Settings = Settings -- General { infile :: FilePath @@ -28,7 +30,7 @@ data Settings = Settings , norun :: Bool -- Output , quiet :: Bool - , sparse :: Bool + , formatConf :: FormatConfig } deriving (Show) {- Command-line parameters -} @@ -43,16 +45,15 @@ settingsParser = Settings <> short 'o' <> metavar "OUTFILE" <> help "If specified, write the memory dump to this file after execution is finished") - <*> flag True False - (long "nodiscover" - <> help "Disable the automatic loading of the .mima-flags and .mima-symbols files") + <*> switchWithNo "discover" True + (help "Disable the automatic loading of the .mima-flags and .mima-symbols files") <*> (optional . strOption) - (long "flags" + (long "flag-file" <> short 'f' <> metavar "FLAGFILE" <> help "A file containing extension memory flags, specified in the .mima-flags format") <*> (optional . strOption) - (long "symbols" + (long "symbol-file" <> short 's' <> metavar "SYMBOLFILE" <> help "A file containing label names and addresses, specified in the .mima-symbols format") @@ -67,14 +68,47 @@ settingsParser = Settings (long "quiet" <> short 'q' <> help "Don't print the memory dump") - <*> flag False True - (long "sparse" - <> help "Don't print memory locations containing only 0x000000 in the memory dump") + <*> formatConfigParser opts :: ParserInfo Settings opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 -{- Main logic -} +{- Loading the flag file -} + +-- If explicit file name: +-- Try to load file +-- Fail if loading fails +-- Elif discover: +-- Try to load file +-- Use defaults if loading fails +-- Else: +-- Use defaults + +loadFlagFile :: FilePath -> Run (Flags (MimaAddress -> Bool)) +loadFlagFile filename = do + lift $ putStrLn $ "Loading flags from " ++ filename + (interpretFlagSpec . getFlagSpec) <$> loadFile readFlagFile filename + +withDefaultFlags :: Run (Flags (MimaAddress -> Bool)) -> Run (Flags (MimaAddress -> Bool)) +withDefaultFlags p = do + result <- tryRun p + case result of + Just flags -> pure flags + Nothing -> do + lift $ putStrLn "Using default flags" + pure noFlags + +loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool)) +loadFlags settings = + case flagFile settings of + Just filename -> loadFlagFile filename + Nothing -> withDefaultFlags $ if discover settings + then loadFlagFile discovered + else throwE "File not specified and discovery turned off" + where + discovered = dropExtension (infile settings) ++ ".mima-flags" + +{- Other functions -} runMima :: Settings -> MimaState -> Flags (MimaAddress -> Bool) -> IO MimaState runMima settings s f = @@ -93,27 +127,18 @@ runMima settings s f = Just e -> T.putStrLn $ toText e pure s' -loadFlagFile :: FilePath -> Run (Flags (MimaAddress -> Bool)) -loadFlagFile filename = (interpretFlagSpec . getFlagSpec) <$> loadFile readFlagFile filename - -loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool)) -loadFlags settings = do - case flagFile settings of - Just filename -> do - lift $ putStrLn $ "Loading flags from specified file: " ++ filename - loadFlagFile filename - Nothing -> do - maybeFlags <- if discover settings then tryLoadDiscovered else pure Nothing - case maybeFlags of - Just flags -> pure flags - Nothing -> do - lift $ putStrLn "Not using flags" - pure noFlags - where - discovered = dropExtension (infile settings) ++ ".mima-flags" - tryLoadDiscovered = do - lift $ putStrLn $ "Loading flags from file: " ++ discovered - tryRun (loadFlagFile discovered) +printState :: MimaState -> Flags (MimaAddress -> Bool) -> LabelSpec -> Settings -> Run () +printState ms flags labels settings = do + let formatEnv = FormatEnv + { feState = ms + , feFlags = flags + , feLabels = labelsByAddress labels + , feConf = formatConf settings + } + lift $ putStrLn "" + lift $ putStrLn "Dump of MiMa state:" + lift $ T.putStrLn $ formatState formatEnv + lift $ putStrLn "" -- TODO exception handling main :: IO () @@ -123,15 +148,14 @@ main = doRun_ $ do lift $ putStrLn $ "Loading memdump at " ++ infile settings ms <- loadStateFromFile (infile settings) - flags <- loadFlags settings + flags <- loadFlags settings + labels <- pure noLabels -- loadSymbolFile settings - ms' <- if norun settings then pure ms else lift (runMima settings ms flags) + ms' <- if norun settings + then pure ms + else lift $ runMima settings ms flags - unless (quiet settings) $ do - lift $ putStrLn "" - lift $ putStrLn "Dump of MiMa state:" - lift $ printStateLn (sparse settings) ms' - lift $ putStrLn "" + unless (quiet settings) $ printState ms flags labels settings forM_ (outfile settings) $ \path -> do lift $ putStrLn $ "Saving memdump at " ++ path diff --git a/src/Mima/Format/State.hs b/src/Mima/Format/State.hs new file mode 100644 index 0000000..fcc47b9 --- /dev/null +++ b/src/Mima/Format/State.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Mima.Format.State + ( FormatConfig(..) + , defaultFormatConfig + , FormatEnv(..) + , FormatReader + , Formatter + -- * Flags + , fRegisterFlags + , fMemoryFlags + , fFlags + -- * Addresses + , fAddress + -- * Words + , fWord + -- * The whole state + , formatState + ) where + +import Control.Monad.Trans.Reader +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T + +import Mima.Flag +import Mima.Format.Common +import Mima.Label +import Mima.State +import Mima.Word + +data FormatConfig = FormatConfig + { fcSparse :: Bool + , fcShowRegisterFlags :: Bool + , fcShowMemoryFlags :: Bool + , fcShowAddressDec :: Bool + , fcShowAddressHex :: Bool + , fcShowAddressBin :: Bool + , fcShowWordDec :: Bool + , fcShowWordHex :: Bool + , fcShowWordBin :: Bool + , fcShowInstructions :: Bool -- Currently unused + , fcShowLabels :: Bool -- Currently unused + } deriving (Show) + +defaultFormatConfig :: FormatConfig +defaultFormatConfig = FormatConfig + { fcSparse = True + , fcShowRegisterFlags = True + , fcShowMemoryFlags = True + , fcShowAddressDec = True + , fcShowAddressHex = True + , fcShowAddressBin = False + , fcShowWordDec = True + , fcShowWordHex = True + , fcShowWordBin = False + , fcShowInstructions = True + , fcShowLabels = False + } + +data FormatEnv = FormatEnv + { feState :: MimaState + , feFlags :: Flags (MimaAddress -> Bool) + , feLabels :: Map.Map MimaAddress (Set.Set LabelName) + , feConf :: FormatConfig + } + +type FormatReader a = Reader FormatEnv a +type Formatter = FormatReader T.Text + +{- Flags -} + +flagAt :: (MimaState -> MimaAddress) -> Char -> MimaState -> MimaAddress -> T.Text +flagAt f c s a = T.singleton $ if f s == a then c else ' ' + +iarFlag :: MimaState -> MimaAddress -> T.Text +iarFlag = flagAt msIAR '>' + +raFlag :: MimaState -> MimaAddress -> T.Text +raFlag = flagAt msRA 'R' + +spFlag :: MimaState -> MimaAddress -> T.Text +spFlag = flagAt msSP 'S' + +fpFlag :: MimaState -> MimaAddress -> T.Text +fpFlag = flagAt msFP 'F' + +fRegisterFlags :: MimaState -> MimaAddress -> T.Text +fRegisterFlags s a = mconcat $ [fpFlag, spFlag, raFlag, iarFlag] <*> pure s <*> pure a + +fMemoryFlags :: Flags (MimaAddress -> Bool) -> MimaAddress -> T.Text +fMemoryFlags flags a = + let b = if flagBreakpoint flags a then 'b' else ' ' + e = if flagExecutable flags a then 'e' else ' ' + r = if flagReadOnly flags a then 'r' else ' ' + in T.pack [b, e, r] + +fFlags :: MimaAddress -> Formatter +fFlags a = do + env <- ask + let conf = feConf env + s = feState env + f = feFlags env + memoryFlags = if fcShowMemoryFlags conf then fMemoryFlags f a else "" + registerFlags = if fcShowRegisterFlags conf then fRegisterFlags s a else "" + pure $ memoryFlags <> registerFlags + +{- Addresses -} + +fAddressBin :: MimaAddress -> T.Text +fAddressBin = chunkyBin . fixWidthBin (4 * 5) . toBin + +fAddressDec :: MimaAddress -> T.Text +fAddressDec = fixWidthDec 9 . chunkyDec . toDec + +fAddressHex :: MimaAddress -> T.Text +fAddressHex = chunkyHex . fixWidthHex 5 . toHex + +fAddress :: MimaAddress -> Formatter +fAddress a = do + env <- ask + let conf = feConf env + dec = if fcShowAddressDec conf then [fAddressDec] else [] + hex = if fcShowAddressHex conf then [fAddressHex] else [] + bin = if fcShowAddressBin conf then [fAddressBin] else [] + formats = (dec ++ hex ++ bin) <*> pure a + pure $ "[" <> T.intercalate "," formats <> "]" + +{- Words -} + +fWordBin :: MimaWord -> T.Text +fWordBin = chunkyBin . fixWidthBin (4 * 6) . toBin + +fWordDec :: MimaWord -> T.Text +fWordDec = fixWidthDec 10 . chunkyDec . toDec + +fWordHex :: MimaWord -> T.Text +fWordHex = chunkyHex . fixWidthHex 6 . toHex + +fWord :: MimaWord -> Formatter +fWord a = do + env <- ask + let conf = feConf env + dec = if fcShowWordDec conf then [fWordDec] else [] + hex = if fcShowWordHex conf then [fWordHex] else [] + bin = if fcShowWordBin conf then [fWordBin] else [] + formats = (dec ++ hex ++ bin) <*> pure a + pure $ "{" <> T.intercalate "," formats <> "}" + +{- Memory -} + +fMemoryLn :: MimaAddress -> Formatter +fMemoryLn a = do + env <- ask + let mem = msMemory $ feState env + w = readAt a mem + flags <- fFlags a + addr <- fAddress a + word <- fWord w + pure $ flags <> " " <> addr <> " " <> word <> "\n" + +fMemory :: Formatter +fMemory = do + env <- ask + let conf = feConf env + mem = msMemory $ feState env + addrs = if fcSparse conf then sparseUsedAddresses mem else usedAddresses mem + mconcat <$> mapM fMemoryLn addrs + +{- And finally, the whole state -} + +fState :: Formatter +fState = fMemory + +formatState :: FormatEnv -> T.Text +formatState = runReader fState diff --git a/src/Mima/Label.hs b/src/Mima/Label.hs index 9453f93..766cc2f 100644 --- a/src/Mima/Label.hs +++ b/src/Mima/Label.hs @@ -2,11 +2,12 @@ module Mima.Label ( LabelName , LabelSpec , labelsByAddress + , noLabels ) where import qualified Data.Map as Map -import qualified Data.Text as T import qualified Data.Set as Set +import qualified Data.Text as T import Mima.Word @@ -19,3 +20,6 @@ labelsByAddress = ($ Map.empty) . reverse . map (\(l, a) -> Map.insertWith Set.union a (Set.singleton l)) . Map.assocs + +noLabels :: LabelSpec +noLabels = Map.empty diff --git a/src/Mima/Options.hs b/src/Mima/Options.hs new file mode 100644 index 0000000..4b9f8ff --- /dev/null +++ b/src/Mima/Options.hs @@ -0,0 +1,28 @@ +module Mima.Options + ( switchWithNo + , formatConfigParser + ) where + +import Options.Applicative + +import Mima.Format.State + +switchWithNo :: String -> Bool -> Mod FlagFields Bool -> Parser Bool +switchWithNo name True fields = flag' False (long ("no-" ++ name) <> fields) + <|> flag True True (long name <> fields) +switchWithNo name False fields = flag' True (long name <> fields) + <|> flag False False (long ("no-" ++ name) <> fields) + +formatConfigParser :: Parser FormatConfig +formatConfigParser = FormatConfig + <$> switchWithNo "sparse" False mempty + <*> switchWithNo "register-flags" True mempty + <*> switchWithNo "memory-flags" True mempty + <*> switchWithNo "address-dec" True mempty + <*> switchWithNo "address-hex" True mempty + <*> switchWithNo "address-bin" False mempty + <*> switchWithNo "word-dec" True mempty + <*> switchWithNo "word-hex" True mempty + <*> switchWithNo "word-bin" False mempty + <*> switchWithNo "instructions" True mempty + <*> switchWithNo "labels" True mempty