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).
This commit is contained in:
parent
45ec7d1708
commit
8bfce48a7f
4 changed files with 273 additions and 41 deletions
|
|
@ -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
|
||||
|
|
|
|||
176
src/Mima/Format/State.hs
Normal file
176
src/Mima/Format/State.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
28
src/Mima/Options.hs
Normal file
28
src/Mima/Options.hs
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue