Garmelon/mima-tools
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Begin rewrite

Browse source 
... by deleting most files. By the theory of evolution, the remaining ones will
get stronger over the next commits. That's how it works, isn't it?
This commit is contained in:
Joscha 2020-03-25 21:29:11 +00:00
parent 3e0f4e22b1
commit b1274d5d2c
37 changed files with 218 additions and 2424 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

120
app/MimaAsm/Main.hs
View file

@ -1,120 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad.Trans.Class
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Options.Applicative
import System.FilePath
import Mima.Flag
import Mima.Format.FlagFile
import Mima.Format.SymbolFile
import Mima.IO
import Mima.Label
import Mima.Load
import Mima.Options
import Mima.Parse.Assembly
data Settings = Settings
{ infile :: FilePath
, outfile :: Maybe FilePath
, discover :: Bool
, flagFile :: Maybe FilePath
, symbolFile :: Maybe FilePath
} deriving (Show)
getOutfile :: Settings -> FilePath
getOutfile settings = fromMaybe discoveredPath $ outfile settings
where
discoveredPath = dropExtension (infile settings) ++ ".mima"
getFlagFile :: Settings -> File
getFlagFile settings =
case flagFile settings of
Just path -> RequiredFile path
Nothing -> if discover settings
then OptionalFile discoveredPath
else NoFile
where
discoveredPath = dropExtension (getOutfile settings) ++ ".mima-flags"
getSymbolFile :: Settings -> File
getSymbolFile settings =
case symbolFile settings of
Just path -> RequiredFile path
Nothing -> if discover settings
then OptionalFile discoveredPath
else NoFile
where
discoveredPath = dropExtension (getOutfile settings) ++ ".mima-symbols"
{- Command-line parameters -}
settingsParser :: Parser Settings
settingsParser = Settings
<$> strArgument
(metavar "INFILE"
<> help "The .mimasm file to assemble")
<*> (optional . strOption)
(long "out"
<> short 'o'
<> metavar "OUTFILE"
<> help "The .mima file to write the assembled result to"
<> showDefault)
<*> switchWithNo "discover" True
"Derive the file names for the .mima-flags and .mima-symbols files from the name of the input file"
<*> (optional . strOption)
(long "flag-file"
<> short 'f'
<> metavar "FLAGFILE"
<> help "A file containing extension memory flags, specified in the .mima-flags format")
<*> (optional . strOption)
(long "symbol-file"
<> short 's'
<> metavar "SYMBOLFILE"
<> help "A file containing label names and addresses, specified in the .mima-symbols format")
opts :: ParserInfo Settings
opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 <> footer flagFooter
{- Saving supplemental files -}
printFile :: T.Text -> File -> Run ()
printFile name NoFile =
lift $ T.putStrLn $ "Not saving " <> name <> ": No file specified and discovery turned off"
printFile name (OptionalFile path) =
lift $ T.putStrLn $ "Saving " <> name <> " to " <> T.pack path
printFile name (RequiredFile path) =
lift $ T.putStrLn $ "Saving " <> name <> " to " <> T.pack path
saveFlags :: RawFlags -> Settings -> Run ()
saveFlags flags settings
| Map.null flags = lift $ putStrLn "No flags to save"
| otherwise = do
let file = getFlagFile settings
printFile "flags" file
storeFile' file (formatFlagFile flags)
saveSymbols :: LabelSpec -> Settings -> Run ()
saveSymbols labels settings = do
let file = getSymbolFile settings
printFile "symbols" file
storeFile' file (formatSymbolFile labels)
main :: IO ()
main = doRun_ $ do
settings <- lift $ execParser opts
lift $ putStrLn $ "Loading assembly file at " ++ infile settings
(state, labels, flags) <- loadFile readAssembly (infile settings)
lift $ putStrLn "Parsing successful"
lift $ putStrLn $ "Writing result to " ++ getOutfile settings
saveStateToFile (getOutfile settings) state
saveFlags flags settings
saveSymbols labels settings

175
app/MimaRun/Main.hs
View file

@ -1,175 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad
import Control.Monad.Trans.Class
import Data.Maybe
import qualified Data.Text as T
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.Parse.SymbolFile
import Mima.State
import Mima.Util
import Mima.Word
data Settings = Settings
-- General
{ infile :: FilePath
, outfile :: Maybe FilePath
, discover :: Bool
, flagFile :: Maybe FilePath
, symbolFile :: Maybe FilePath
-- Running
, steps :: Maybe Integer
, norun :: Bool
-- Output
, quiet :: Bool
, formatConf :: FormatConfig
} deriving (Show)
getFlagFile :: Settings -> File
getFlagFile settings =
case flagFile settings of
Just path -> RequiredFile path
Nothing -> if discover settings
then OptionalFile discoveredPath
else NoFile
where
discoveredPath = dropExtension (infile settings) ++ ".mima-flags"
getSymbolFile :: Settings -> File
getSymbolFile settings =
case symbolFile settings of
Just path -> RequiredFile path
Nothing -> if discover settings
then OptionalFile discoveredPath
else NoFile
where
discoveredPath = dropExtension (infile settings) ++ ".mima-symbols"
{- Command-line parameters -}
settingsParser :: Parser Settings
settingsParser = Settings
<$> strArgument
(metavar "INFILE"
<> help "The memory dump to load and execute")
<*> (optional . strOption)
(long "out"
<> short 'o'
<> metavar "OUTFILE"
<> help "If specified, write the memory dump to this file after execution is finished")
<*> switchWithNo "discover" True
"Derive the file names for the .mima-flags and .mima-symbols files from the name of the input file"
<*> (optional . strOption)
(long "flag-file"
<> short 'f'
<> metavar "FLAGFILE"
<> help "A file containing extension memory flags, specified in the .mima-flags format")
<*> (optional . strOption)
(long "symbol-file"
<> short 's'
<> metavar "SYMBOLFILE"
<> help "A file containing label names and addresses, specified in the .mima-symbols format")
<*> (optional . option auto)
(long "steps"
<> short 'n'
<> metavar "N"
<> help "How many instructions to execute (if not specified, runs until HALT or execution exception)")
<*> flag False True
(long "no-run"
<> help "Don't run the MiMa. Use the initial state for all further actions. Roughly equivalent to --steps 0")
<*> flag False True
(long "quiet"
<> short 'q'
<> help "Don't print the memory dump")
<*> formatConfigParser
opts :: ParserInfo Settings
opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 <> footer flagFooter
{- Loading supplemental files -}
printFile :: T.Text -> File -> Run ()
printFile name NoFile =
lift $ T.putStrLn $ "Not loading " <> name <> ": No file specified and discovery turned off"
printFile name (OptionalFile path) =
lift $ T.putStrLn $ "Attempting to load " <> name <> " from " <> T.pack path
printFile name (RequiredFile path) =
lift $ T.putStrLn $ "Loading " <> name <> " from " <> T.pack path
loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool))
loadFlags settings = do
let file = getFlagFile settings
printFile "flags" file
mRawFlags <- loadFile' readFlagFile file
pure $ case mRawFlags of
Nothing -> noFlags
Just flagSpec -> interpretFlagSpec $ getFlagSpec flagSpec
loadSymbols :: Settings -> Run LabelSpec
loadSymbols settings = do
let file = getSymbolFile settings
printFile "symbols" file
fromMaybe noLabels <$> loadFile' readSymbolFile file
{- Other functions -}
runMima :: Settings -> MimaState -> Flags (MimaAddress -> Bool) -> IO MimaState
runMima settings s f =
case steps settings of
Nothing -> do
putStrLn "Running until HALT or execution exception..."
let (s', e, x) = run f s
putStrLn $ "Ran for " ++ show x ++ " steps"
T.putStrLn $ toText e
pure s'
Just n -> do
let (s', me, x) = runN f n s
putStrLn $ "Ran for " ++ show x ++ " steps"
case me of
Nothing -> putStrLn "Encountered no exception"
Just e -> T.putStrLn $ toText e
pure s'
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
main :: IO ()
main = doRun_ $ do
settings <- lift $ execParser opts
lift $ putStrLn $ "Loading memdump from " ++ infile settings
ms <- loadStateFromFile (infile settings)
flags <- loadFlags settings
labels <- loadSymbols settings
ms' <- if norun settings
then pure ms
else lift $ runMima settings ms flags
unless (quiet settings) $ printState ms' flags labels settings
forM_ (outfile settings) $ \path -> do
lift $ putStrLn $ "Saving memdump at " ++ path
saveStateToFile path ms'

62
package.yaml
View file

@ -1,67 +1,21 @@
name: mima-tools
version: 0.1.0.0
github: "Garmelon/mima-tools"
license: MIT
author: "Garmelon"
maintainer: "joscha@plugh.de"
copyright: "2019 Garmelon"
author: Garmelon <joscha@plugh.de>
copyright: 2019-2020 Garmelon
synopsis: Tools for the MiMa (MinimalMaschine)
description: Please see the README on GitHub at <https://github.com/Garmelon/mima-tools#readme>
github: Garmelon/mima-tools
extra-source-files:
- README.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/Garmelon/mima-tools#readme>
dependencies:
- base >= 4.7 && < 5
- ansi-terminal
- binary
- bytestring
- containers
- filepath
- megaparsec
- optparse-applicative
- text
- transformers
- OddWord >= 1.0 && < 1.1
- containers
- text
library:
source-dirs: src
executables:
mima-run:
main: Main.hs
source-dirs: app/MimaRun
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- mima-tools
mima-asm:
main: Main.hs
source-dirs: app/MimaAsm
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- mima-tools
tests:
mima-tools-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- mima-tools

142
src/Mima/Flag.hs
View file

@ -1,142 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
module Mima.Flag
( AddressRange
, lowerAddress
, upperAddress
, range
, rangeToAddresses
, rangeContains
, simplifyRanges
, AddressSpec
, rangesToSpec
, specToRanges
, specNull
, specContains
, Flag(..)
, flagChar
, Flags(..)
, rawFlags
, RawFlags
, FlagSpec
, getFlagSpec
, interpretFlagSpec
, noFlags
) 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)
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
}
type RawFlags = Map.Map AddressRange (Set.Set Char)
type FlagSpec = Flags AddressSpec
getFlagSpec :: RawFlags -> FlagSpec
getFlagSpec af =
let isInSet :: Flag -> Set.Set Char -> Bool
isInSet f s = flagChar f `Set.member` s
getAddressSpec :: Flag -> AddressSpec
getAddressSpec f = rangesToSpec $ map fst $ filter (isInSet f . snd) $ Map.assocs af
in getAddressSpec <$> rawFlags
interpretFlagSpec :: FlagSpec -> Flags (MimaAddress -> Bool)
interpretFlagSpec spec =
let conditions :: Flags (AddressSpec -> MimaAddress -> Bool)
conditions = Flags
{ flagBreakpoint = specContains
, flagExecutable = \as -> if specNull as then const True else specContains as
, flagReadOnly = specContains
}
in conditions <*> spec
-- | These checks should behave as if no flags were set at all.
noFlags :: Flags (MimaAddress -> Bool)
noFlags = Flags
{ flagBreakpoint = const False
, flagExecutable = const True
, flagReadOnly = const False
}

18
src/Mima/Format/Common.hs → src/Mima/Format.hs
View file

@ -1,7 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Format.Common
( toBin
module Mima.Format
( ToText(..)
, toBin
, toDec
, toHex
, negative
@ -17,6 +18,19 @@ module Mima.Format.Common
import qualified Data.Text as T
import Numeric
-- | A class for types that can be converted to 'T.Text'.
--
-- This class does not mean to convert elements to text in a
-- standardized way. It is just to reduce the clutter of functions
-- with names like @somethingToText@.
--
-- Only create an instance of this class when there is an obvious,
-- preferrable way of converting something to text! If there are
-- multiple "obvious" options, create no instance of this class and
-- instead name the functions individually.
class ToText a where
toText :: a -> T.Text
toBin :: (Integral a, Show a) => a -> T.Text
toBin a
| a < 0 = "-" <> toBin (- a)

34
src/Mima/Format/FlagFile.hs
View file

@ -1,34 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Format.FlagFile
( formatFlagSet
, formatFlagFile
) where
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.Word
fAddress :: MimaAddress -> T.Text
fAddress = fixWidthHex 5 . toHex
formatFlagSet :: Set.Set Char -> T.Text
formatFlagSet = T.pack . Set.toAscList
fRange :: AddressRange -> T.Text
fRange r
| lower == upper = fAddress lower
| otherwise = fAddress lower <> "-" <> fAddress upper
where
lower = lowerAddress r
upper = upperAddress r
fLine :: (AddressRange, Set.Set Char) -> T.Text
fLine (r, s) = fRange r <> ": " <> formatFlagSet s <> "\n"
formatFlagFile :: RawFlags -> T.Text
formatFlagFile = mconcat . map fLine . Map.assocs

34
src/Mima/Format/Instruction.hs
View file

@ -1,34 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Format.Instruction
( formatLargeValue
, formatSmallValue
, formatSmallOpcode
, formatLargeOpcode
, formatInstruction
) where
import qualified Data.Text as T
import Mima.Format.Common
import Mima.Instruction
import Mima.Word
formatLargeValue :: LargeValue -> T.Text
formatLargeValue = negative toDec
formatSmallValue :: SmallValue -> T.Text
formatSmallValue = negative toDec
formatSmallOpcode :: SmallOpcode -> T.Text
formatSmallOpcode = T.pack . show
formatLargeOpcode :: LargeOpcode -> T.Text
formatLargeOpcode = T.pack . show
formatInstruction :: Instruction -> T.Text
formatInstruction (SmallInstruction so lv) = formatSmallOpcode so <> " " <> formatLargeValue lv
formatInstruction (LargeInstruction lo sv) =
if argumentIsOptional lo && sv == 0
then formatLargeOpcode lo
else formatLargeOpcode lo <> " " <> formatSmallValue sv

239
src/Mima/Format/State.hs
View file

@ -1,239 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Format.State
( FormatConfig(..)
, FormatEnv(..)
, FormatReader
, Formatter
-- * Flags
, fRegisterFlags
, fMemoryFlags
, fFlags
-- * Addresses
, fAddress
-- * Words
, fWord
-- * Memory
, fMemory
-- * Registers
, fRegisters
-- * 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.Format.Instruction
import Mima.Instruction
import Mima.Label
import Mima.State
import Mima.Word
data FormatConfig = FormatConfig
{ fcSparse :: Bool
, fcShowRegisters :: Bool
, fcShowMemory :: Bool
, fcShowMemoryFlags :: Bool
, fcShowRegisterFlags :: Bool
, fcShowAddressDec :: Bool
, fcShowAddressHex :: Bool
, fcShowAddressBin :: Bool
, fcShowWordDec :: Bool
, fcShowWordHex :: Bool
, fcShowWordBin :: Bool
, fcShowInstructions :: Bool -- Currently unused
, fcShowLabels :: Bool -- Currently unused
} deriving (Show)
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 ""
space = if fcShowMemoryFlags conf || fcShowRegisterFlags conf then " " else ""
pure $ memoryFlags <> registerFlags <> space
{- 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 = [fAddressDec | fcShowAddressDec conf]
hex = [fAddressHex | fcShowAddressHex conf]
bin = [fAddressBin | fcShowAddressBin conf]
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 = [fWordDec | fcShowWordDec conf]
hex = [fWordHex | fcShowWordHex conf]
bin = [fWordBin | fcShowWordBin conf]
formats = (dec ++ hex ++ bin) <*> pure a
pure $ "{" <> T.intercalate ", " formats <> "}"
{- Instructions and Labels -}
fLabels :: Set.Set LabelName -> T.Text
fLabels = mconcat . map (<> ": ") . Set.toAscList
fDecoration :: MimaAddress -> Formatter
fDecoration a = do
env <- ask
let conf = feConf env
-- Labels
labels = Map.findWithDefault Set.empty a $ feLabels env
labelsStr = if fcShowLabels conf then fLabels labels else ""
-- Instruction
word = readAt a $ msMemory $ feState env
instrStr = case wordToInstruction word of
Left _ -> ""
Right i -> if fcShowInstructions conf then formatInstruction i else ""
pure $ labelsStr <> instrStr
{- 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
deco <- fDecoration a
pure $ flags <> addr <> " " <> word <> " " <> deco <> "\n"
interestingAddresses :: FormatReader (Set.Set MimaAddress)
interestingAddresses = do
env <- ask
let conf = feConf env
s = feState env
regAddrs = if fcShowRegisterFlags conf
then Set.fromList [msIAR s, msRA s, msSP s, msFP s]
else Set.empty
labelAddrs = if fcShowLabels conf
then Map.keysSet $ feLabels env
else Set.empty
pure $ Set.union regAddrs labelAddrs
getAddresses :: FormatReader [MimaAddress]
getAddresses = do
env <- ask
let conf = feConf env
mem = msMemory $ feState env
if fcSparse conf
then do
interesting <- interestingAddresses
pure $ Set.toAscList $ Set.union interesting $ Set.fromList $ usedAddresses mem
else pure $ continuousUsedAddresses 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 = do
env <- ask
let conf = feConf env
regText <- ("--< REGISTERS >--\n" <>) <$> fRegisters
memText <- ("--< MEMORY >--\n" <>) <$> fMemory
pure $ (if fcShowRegisters conf then regText else "")
<> (if fcShowMemory conf then memText else "")
formatState :: FormatEnv -> T.Text
formatState = runReader fState

25
src/Mima/Format/SymbolFile.hs
View file

@ -1,25 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Format.SymbolFile
( formatSymbolFile
) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Mima.Format.Common
import Mima.Word
import Mima.Label
fAddress :: MimaAddress -> T.Text
fAddress = fixWidthHex 5 . toHex
fLabels :: Set.Set LabelName -> T.Text
fLabels = T.intercalate " " . Set.toAscList
fLine :: (MimaAddress, Set.Set LabelName) -> T.Text
fLine (a, s) = fAddress a <> ": " <> fLabels s <> "\n"
formatSymbolFile :: LabelSpec -> T.Text
formatSymbolFile = mconcat . map fLine . Map.assocs . labelsByAddress

103
src/Mima/IO.hs
View file

@ -1,103 +0,0 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
module Mima.IO
( Run
, doRun
, doRun_
, tryRun
, readTextFile
, writeTextFile
, loadFile
, storeFile
, File(..)
, loadFile'
, storeFile'
) where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.IO.Error
import Text.Megaparsec
import Mima.Parse.Weed
type Run a = ExceptT String IO a
doRun :: Run a -> IO (Either String a)
doRun = runExceptT
doRun_ :: Run () -> IO ()
doRun_ r = do
result <- doRun r
case result of
Right () -> pure ()
Left e -> putStrLn e
tryRun :: Run a -> Run (Maybe a)
tryRun r = do
result <- lift $ runExceptT r
case result of
Right a -> pure $ Just a
Left e -> do
lift $ putStrLn e
pure Nothing
handleOpenFileError :: FilePath -> IOError -> IO (Either String a)
handleOpenFileError filepath e = if isRelevantError
then pure $ Left $ "Can't open file " <> filepath <> ": " <> ioeGetErrorString e
else ioError e
where
isRelevantError = isAlreadyInUseError e || isDoesNotExistError e || isPermissionError e
readTextFile :: FilePath -> Run T.Text
readTextFile filepath = do
eitherContent <- lift $ catchIOError (Right <$> T.readFile filepath) (handleOpenFileError filepath)
except eitherContent
writeTextFile :: FilePath -> T.Text -> Run ()
writeTextFile filepath content = do
result <- lift $ catchIOError (Right <$> T.writeFile filepath content) (handleOpenFileError filepath)
except result
loadFile :: (FilePath -> T.Text -> Either WeedErrorBundle a) -> FilePath -> Run a
loadFile f path = do
content <- readTextFile path
case f path content of
Left errorBundle -> throwE $ errorBundlePretty errorBundle
Right result -> pure result
-- To have a consistent naming scheme
storeFile :: FilePath -> T.Text -> Run ()
storeFile = writeTextFile
data File
= NoFile
| OptionalFile FilePath
| RequiredFile FilePath
deriving (Show)
loadTextFile :: File -> Run (Maybe (FilePath, T.Text))
loadTextFile NoFile = pure Nothing
loadTextFile (OptionalFile path) = do
mContent <- tryRun $ readTextFile path
pure $ (path,) <$> mContent
loadTextFile (RequiredFile path) = do
content <- readTextFile path
pure $ Just (path, content)
loadFile' :: (FilePath -> T.Text -> Either WeedErrorBundle a) -> File -> Run (Maybe a)
loadFile' f file = do
mContent <- loadTextFile file
case mContent of
Nothing -> pure Nothing
Just (path, content) -> case f path content of
Left errorBundle -> throwE $ errorBundlePretty errorBundle
Right result -> pure $ Just result
storeFile' :: File -> T.Text -> Run ()
storeFile' NoFile _ = pure ()
storeFile' (OptionalFile path) content = () <$ tryRun (writeTextFile path content)
storeFile' (RequiredFile path) content = writeTextFile path content

25
src/Mima/Label.hs
View file

@ -1,25 +0,0 @@
module Mima.Label
( LabelName
, LabelSpec
, labelsByAddress
, noLabels
) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Mima.Word
type LabelName = T.Text
type LabelSpec = Map.Map LabelName MimaAddress
labelsByAddress :: LabelSpec -> Map.Map MimaAddress (Set.Set LabelName)
labelsByAddress = ($ Map.empty)
. mconcat
. reverse
. map (\(l, a) -> Map.insertWith Set.union a (Set.singleton l))
. Map.assocs
noLabels :: LabelSpec
noLabels = Map.empty

66
src/Mima/Load.hs
View file

@ -1,66 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
module Mima.Load
( loadStateFromFile
, saveStateToFile
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.Binary
import qualified Data.ByteString.Lazy as BS
import Mima.IO
import Mima.State
import Mima.Word
-- To prevent orphan instances and keep the compiler happy
newtype LD t = LD { unLD :: t }
instance Binary (LD MimaWord) where
put mw = do
let (w1, w2, w3) = wordToBytes $ unLD mw
forM_ [w1, w2, w3] put
get = do
bytes <- (,,) <$> get <*> get <*> get
pure $ LD $ bytesToWord bytes
instance Binary (LD LargeValue) where
put = put . LD . largeValueToWord . unLD
get = LD . getLargeValue . unLD <$> get
instance Binary (LD MimaMemory) where
put = mapM_ (put . LD) . memoryToWords . unLD
get = LD . wordsToMemory . map unLD <$> many get
instance Binary (LD MimaState) where
put ldms = do
let ms = unLD ldms
put $ LD $ msIAR ms
put $ LD $ msACC ms
put $ LD $ msRA ms
put $ LD $ msSP ms
put $ LD $ msFP ms
put $ LD $ msMemory ms
get = do
iar <- unLD <$> get
acc <- unLD <$> get
ra <- unLD <$> get
sp <- unLD <$> get
fp <- unLD <$> get
mem <- unLD <$> get
pure $ LD $ MimaState iar acc ra sp fp mem
loadStateFromFile :: FilePath -> Run MimaState
loadStateFromFile path = do
bs <- lift $ BS.readFile path
case decodeOrFail bs of
Left ( _, _, e) -> throwE e
Right (bs', _, ldms)
| BS.null bs' -> pure $ unLD ldms
| otherwise -> throwE "Input was not consumed fully"
saveStateToFile :: FilePath -> MimaState -> Run ()
saveStateToFile path = lift . BS.writeFile path . encode . LD

62
src/Mima/Options.hs
View file

@ -1,62 +0,0 @@
module Mima.Options
( flagFooter
, switchWithNo
, hiddenSwitchWithNo
, formatConfigParser
) where
import Options.Applicative
import Mima.Format.State
flagFooter :: String
flagFooter = "To disable an option, prepend 'no-' to its name (e. g. to disable"
++ " '--discover', use '--no-discover'). This only applies to options"
++ " with a default of 'enabled' or 'disabled'."
enabledOrDisabled :: Bool -> String
enabledOrDisabled False = "disabled"
enabledOrDisabled True = "enabled"
switchWithNo :: String -> Bool -> String -> Parser Bool
switchWithNo name defaultValue helpText =
flag' False noMod <|> flag defaultValue True yesMod
where
noMod = long ("no-" ++ name) <> hidden
yesMod = long name <> help (helpText ++ " (default: " ++ enabledOrDisabled defaultValue ++ ")")
hiddenSwitchWithNo :: String -> Bool -> String -> Parser Bool
hiddenSwitchWithNo name defaultValue helpText =
flag' False noMod <|> flag defaultValue True yesMod
where
noMod = long ("no-" ++ name) <> hidden
yesMod = long name <> hidden <> help (helpText ++ " (default: " ++ enabledOrDisabled defaultValue ++ ")")
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" True
"Show 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 "address-dec" True
"Display addresses in decimal"
<*> hiddenSwitchWithNo "address-hex" True
"Display addresses in hexadecimal"
<*> hiddenSwitchWithNo "address-bin" False
"Display addresses in binary"
<*> hiddenSwitchWithNo "word-dec" True
"Display words in decimal"
<*> hiddenSwitchWithNo "word-hex" True
"Display words in hexadecimal"
<*> hiddenSwitchWithNo "word-bin" False
"Display words in binary"
<*> hiddenSwitchWithNo "instructions" True
"Show instructions"
<*> hiddenSwitchWithNo "labels" True
"Show labels from the symbol file"

47
src/Mima/Parse/Assembly.hs
View file

@ -1,47 +0,0 @@
module Mima.Parse.Assembly
( parseAssembly
, weedAssembly
, formatAssembly
, readAssembly
) where
import Control.Monad
import qualified Data.Text as T
import Text.Megaparsec
import Mima.Flag
import Mima.Instruction
import Mima.Label
import Mima.Parse.Assembly.Common
import Mima.Parse.Assembly.Lexeme
import Mima.Parse.Assembly.RawInstruction
import Mima.Parse.Assembly.Statement
import Mima.Parse.Assembly.Weed.Common
import Mima.Parse.Assembly.Weed.Resolve
import Mima.Parse.Assembly.Weed.Statement
import Mima.Parse.Common
import Mima.Parse.Weed
import Mima.State
import Mima.Word
parseAssembly :: Parser [WithOffset (Statement Address)]
parseAssembly = space *> many lNewline *> lStatements <* eof
weedAssembly :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult MimaAddress)
weedAssembly = weedStatements >=> resolveLabels
almostWordToWord :: AlmostWord MimaAddress -> MimaWord
almostWordToWord (AInstruction i) = instructionToWord $ cookInstruction i
almostWordToWord (ALiteral w) = w
formatAssembly :: WeedResult MimaAddress -> (MimaState, LabelSpec, RawFlags)
formatAssembly res =
let mem = almostWordToWord <$> wrMemory res
s = registersToState (wrRegisters res) (mapToMemory mem)
in (s, wrLabels res, wrFlags res)
readAssembly :: FilePath -> T.Text -> Either WeedErrorBundle (MimaState, LabelSpec, RawFlags)
readAssembly filename input = do
unweeded <- parse parseAssembly filename input
weeded <- runWeedBundle filename input $ weedAssembly unweeded
pure $ formatAssembly weeded

41
src/Mima/Parse/Assembly/Common.hs
View file

@ -1,41 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.Assembly.Common
( number
, word
, largeValue
, smallValue
, Address(..)
, address
) where
import Text.Megaparsec
import qualified Text.Megaparsec.Char.Lexer as L
import Mima.Label
import Mima.Parse.Assembly.Lexeme
import Mima.Parse.Common
import Mima.Parse.Weed
import Mima.Word
number :: Parser Integer
number = L.signed (pure ()) $
(symbol' "0b" *> binNumber)
<|> (symbol' "0o" *> octNumber)
<|> (symbol' "0x" *> hexNumber)
<|> decNumber
word :: Parser MimaWord
word = label "word (24 bit)" $ asWord number
largeValue :: Parser LargeValue
largeValue = label "large value (20 bit)" $ asLargeValue number
smallValue :: Parser SmallValue
smallValue = label "large value (16 bit)" $ asSmallValue number
data Address = Direct LargeValue | Indirect (WithOffset LabelName)
deriving (Show)
address :: Parser Address
address = (Direct <$> largeValue) <|> (Indirect <$> withOffset labelName)

66
src/Mima/Parse/Assembly/Directive.hs
View file

@ -1,66 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.Assembly.Directive
( SetRegister(..)
, Directive(..)
, lDirective
) where
import qualified Data.Set as Set
import Text.Megaparsec
import qualified Text.Megaparsec.Char as C
import Mima.Parse.Assembly.Common
import Mima.Parse.Assembly.Lexeme
import Mima.Parse.Common
import Mima.Word
data SetRegister a
= SetIAR a
| SetACC MimaWord
| SetRA a
| SetSP a
| SetFP a
deriving (Show)
data Directive a
= DReg (SetRegister a) -- .reg (iar|acc|ra|sp|fp) <initial value>
| DOrg MimaAddress -- .org <address>
| DLit MimaWord -- .lit <word>
| DArr [MimaWord] -- .arr [<word>, ...]
| DFlag (Set.Set Char) -- .flag <chars>
| DFlagOn (Set.Set Char) -- .flagon <chars>
| DFlagOff (Set.Set Char) -- .flagoff <chars>
deriving (Show)
lSetRegister :: Parser (SetRegister Address)
lSetRegister =
SetIAR <$> sepBySpace "iar" address
<|> SetACC <$> sepBySpace "acc" word
<|> SetRA <$> sepBySpace "ra" address
<|> SetSP <$> sepBySpace "sp" address
<|> SetFP <$> sepBySpace "fp" address
where
sepBySpace name parser = C.string' name *> lSpace *> lexeme parser
lWordArray :: Parser [MimaWord]
lWordArray = open *> (word `sepBy` comma) <* close
where
open = lexeme $ symbol "["
comma = lexeme $ symbol ","
close = lexeme $ symbol "]"
lFlags :: Parser (Set.Set Char)
lFlags = Set.unions <$> some (lexeme flag)
lDirective :: Parser (Directive Address)
lDirective = label "assembler directive" $
DReg <$> directive ".reg" lSetRegister
<|> DOrg <$> directive ".org" (lexeme largeValue)
<|> DLit <$> directive ".lit" (lexeme word)
<|> DArr <$> directive ".arr" lWordArray
<|> DFlagOn <$> directive ".flagon" lFlags
<|> DFlagOff <$> directive ".flagoff" lFlags
<|> DFlag <$> directive ".flag" lFlags
where
directive name parser = C.string name *> lSpace *> parser

40
src/Mima/Parse/Assembly/Lexeme.hs
View file

@ -1,40 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.Assembly.Lexeme
( space
, lexeme
, symbol
, symbol'
, lSpace
, lNewline
, lNewlines
) where
import Control.Monad
import qualified Data.Text as T
import Text.Megaparsec
import qualified Text.Megaparsec.Char as C
import qualified Text.Megaparsec.Char.Lexer as L
import Mima.Parse.Common
space :: Parser ()
space = L.space (void whitespace) (L.skipLineComment ";") empty
lexeme :: Parser a -> Parser a
lexeme = L.lexeme space
symbol :: T.Text -> Parser T.Text
symbol = L.symbol space
symbol' :: T.Text -> Parser T.Text
symbol' = L.symbol' space
lSpace :: Parser ()
lSpace = () <$ lexeme whitespace
lNewline :: Parser ()
lNewline = void $ lexeme C.newline
lNewlines :: Parser ()
lNewlines = void (some lNewline) <|> eof

84
src/Mima/Parse/Assembly/RawInstruction.hs
View file

@ -1,84 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.Assembly.RawInstruction
( RawInstruction(..)
, lRawInstruction
, cookInstruction
) where
import Control.Monad
import qualified Data.Text as T
import Text.Megaparsec
import qualified Text.Megaparsec.Char as C
import Mima.Instruction
import Mima.Parse.Assembly.Common
import Mima.Parse.Assembly.Lexeme
import Mima.Parse.Common
import Mima.Word
data RawInstruction a
= RawSmallInstruction SmallOpcode a
| RawLargeInstruction LargeOpcode SmallValue
deriving (Show)
parseByName :: [(T.Text, a)] -> Parser a
parseByName = foldl (<|>) empty . map (\(name, a) -> a <$ C.string' name)
smallOpcode :: Parser SmallOpcode
smallOpcode = parseByName
[ ("ldc", LDC)
, ("ldv", LDV)
, ("stv", STV)
, ("add", ADD)
, ("and", AND)
, ("or", OR)
, ("xor", XOR)
, ("eql", EQL)
, ("jmp", JMP)
, ("jmn", JMN)
, ("ldiv", LDIV)
, ("stiv", STIV)
, ("call", CALL)
, ("adc", ADC)
]
largeOpcode :: Parser LargeOpcode
largeOpcode = parseByName
[ ("halt", HALT)
, ("not", NOT)
, ("rar", RAR)
, ("ret", RET)
, ("ldra", LDRA)
, ("stra", STRA)
, ("ldsp", LDSP)
, ("stsp", STSP)
, ("ldfp", LDFP)
, ("stfp", STFP)
, ("ldrs", LDRS)
, ("strs", STRS)
, ("ldrf", LDRF)
, ("strf", STRF)
]
lRawInstruction :: Parser (RawInstruction Address)
lRawInstruction = label "instruction" $ smallInstruction <|> largeInstruction
where
smallInstruction = do
so <- smallOpcode
void lSpace
lv <- lexeme address
pure $ RawSmallInstruction so lv
largeInstruction = do
lo <- largeOpcode
if argumentIsOptional lo
then do
sv <- lexeme (try (lSpace *> smallValue) <|> pure 0)
pure $ RawLargeInstruction lo sv
else do
sv <- lSpace *> lexeme smallValue
pure $ RawLargeInstruction lo sv
cookInstruction :: RawInstruction MimaAddress -> Instruction
cookInstruction (RawSmallInstruction so lv) = SmallInstruction so lv
cookInstruction (RawLargeInstruction lo sv) = LargeInstruction lo sv

35
src/Mima/Parse/Assembly/Statement.hs
View file

@ -1,35 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.Assembly.Statement
( Statement(..)
, lStatement
, lStatements
) where
import Text.Megaparsec
import Mima.Label
import Mima.Parse.Assembly.Common
import Mima.Parse.Assembly.Directive
import Mima.Parse.Assembly.Lexeme
import Mima.Parse.Assembly.RawInstruction
import Mima.Parse.Common
import Mima.Parse.Weed
data Statement a
= SDirective (Directive a)
| SRawInstruction (RawInstruction a)
| SLabel LabelName
deriving (Show)
lLabel :: Parser LabelName
lLabel = lexeme $ try $ labelName <* symbol ":"
lStatement :: Parser (Statement Address)
lStatement =
try (SDirective <$> lDirective <* lNewlines)
<|> try (SRawInstruction <$> lRawInstruction <* lNewlines)
<|> (SLabel <$> lLabel <* many lNewline)
lStatements :: Parser [WithOffset (Statement Address)]
lStatements = many (withOffset lStatement)

58
src/Mima/Parse/Assembly/Weed/Common.hs
View file

@ -1,58 +0,0 @@
module Mima.Parse.Assembly.Weed.Common
( Registers(..)
, emptyRegisters
, registersToState
, AlmostWord(..)
, WeedResult(..)
, emptyResult
) where
import qualified Data.Map as Map
import Data.Maybe
import Mima.Flag
import Mima.Label
import Mima.Parse.Assembly.RawInstruction
import Mima.State
import Mima.Word
data Registers a = Registers
{ rIAR :: Maybe a
, rACC :: Maybe MimaWord
, rRA :: Maybe a
, rSP :: Maybe a
, rFP :: Maybe a
} deriving (Show)
emptyRegisters :: Registers a
emptyRegisters = Registers
{ rIAR = Nothing
, rACC = Nothing
, rRA = Nothing
, rSP = Nothing
, rFP = Nothing
}
registersToState :: Registers MimaAddress -> MimaMemory -> MimaState
registersToState r = MimaState (fromMaybe 0 $ rIAR r) (fromMaybe 0 $ rACC r)
(fromMaybe 0 $ rRA r) (fromMaybe 0 $ rSP r) (fromMaybe 0 $ rFP r)
data AlmostWord a
= AInstruction (RawInstruction a)
| ALiteral MimaWord
deriving (Show)
data WeedResult a = WeedResult
{ wrRegisters :: Registers a
, wrMemory :: Map.Map MimaAddress (AlmostWord a)
, wrLabels :: Map.Map LabelName MimaAddress
, wrFlags :: RawFlags
} deriving (Show)
emptyResult :: WeedResult a
emptyResult = WeedResult
{ wrRegisters = emptyRegisters
, wrMemory = Map.empty
, wrLabels = Map.empty
, wrFlags = Map.empty
}

55
src/Mima/Parse/Assembly/Weed/Resolve.hs
View file

@ -1,55 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
module Mima.Parse.Assembly.Weed.Resolve
( resolveLabels
) where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import qualified Data.Map as Map
import Mima.Label
import Mima.Parse.Assembly.Common
import Mima.Parse.Assembly.RawInstruction
import Mima.Parse.Assembly.Weed.Common
import Mima.Parse.Weed
import Mima.Word
type RWeed a = ReaderT LabelSpec (Weed WeedError) a
resolve :: Address -> RWeed MimaAddress
resolve (Direct a) = pure a
resolve (Indirect wo) = do
labels <- ask
case labels Map.!? woValue wo of
Just a -> pure a
Nothing -> 0 <$ lift (harmless $ errorAt wo "Could not resolve label")
rRegisters :: Registers Address -> RWeed (Registers MimaAddress)
rRegisters Registers{..} = Registers
<$> resolveMaybe rIAR
<*> pure rACC
<*> resolveMaybe rRA
<*> resolveMaybe rSP
<*> resolveMaybe rFP
where
resolveMaybe :: Maybe Address -> RWeed (Maybe MimaAddress)
resolveMaybe ma = sequenceA $ resolve <$> ma
rRawInstruction :: RawInstruction Address -> RWeed (RawInstruction MimaAddress)
rRawInstruction (RawSmallInstruction so a) = RawSmallInstruction so <$> resolve a
rRawInstruction (RawLargeInstruction lo sv) = pure $ RawLargeInstruction lo sv
rAlmostWord :: AlmostWord Address -> RWeed (AlmostWord MimaAddress)
rAlmostWord (AInstruction i) = AInstruction <$> rRawInstruction i
rAlmostWord (ALiteral w) = pure $ ALiteral w
rWeedResult :: WeedResult Address -> RWeed (WeedResult MimaAddress)
rWeedResult WeedResult{..} = WeedResult
<$> rRegisters wrRegisters
<*> traverse rAlmostWord wrMemory
<*> pure wrLabels
<*> pure wrFlags
resolveLabels :: WeedResult Address -> Weed WeedError (WeedResult MimaAddress)
resolveLabels wr = runReaderT (rWeedResult wr) (wrLabels wr)

176
src/Mima/Parse/Assembly/Weed/Statement.hs
View file

@ -1,176 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
module Mima.Parse.Assembly.Weed.Statement
( weedStatements
) where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Mima.Flag
import Mima.Format.FlagFile
import Mima.Label
import Mima.Parse.Assembly.Common
import Mima.Parse.Assembly.Directive
import Mima.Parse.Assembly.RawInstruction
import Mima.Parse.Assembly.Statement
import Mima.Parse.Assembly.Weed.Common
import Mima.Parse.Weed
import Mima.Word
data WeedState = WeedState
{ wsAt :: MimaAddress
, wsOccupied :: Bool
, wsLastFlagsAt :: MimaAddress -- The address of the last flags change
, wsOpenFlags :: Set.Set Char -- Which flags are currently active
, wsResult :: WeedResult Address
} deriving (Show)
initialState :: WeedState
initialState = WeedState
{ wsAt = 0
, wsOccupied = False
, wsLastFlagsAt = 0
, wsOpenFlags = Set.empty
, wsResult = emptyResult
}
-- Sweet!
type SWeed a = StateT WeedState (Weed WeedError) a
{- State manipulation -}
-- Yes, I know that lenses would probably make the below code much nicer. I may
-- get around to that eventually.
modifyResult :: (WeedResult Address -> WeedResult Address) -> SWeed ()
modifyResult f = modify (\s -> s{wsResult = f (wsResult s)})
{- Let's start weeding -}
-- | Advance to the next unoccupied address and return that. This function
-- either returns the current wsAt (if not wsOccupied) or advances wsAt and
-- returns that.
--
-- This function takes an object with an offset, which it uses to produce an
-- error if it could not advance to an unoccupied address.
toNextFree :: WithOffset a -> SWeed MimaAddress
toNextFree thing = do
s@WeedState{..} <- get
if wsOccupied
then if wsAt >= maxBound
then lift $ critical $ errorAt thing "No more space in memory, already at max address"
else let next = wsAt + 1 in next <$ put s{wsAt = next, wsOccupied = False}
else pure wsAt
helpSetRegister :: WithOffset a
-> (Registers Address -> Maybe c)
-> (Registers Address -> Registers Address)
-> SWeed ()
helpSetRegister thing readF writeF = do
WeedState{..} <- get
case readF (wrRegisters wsResult) of
Nothing -> modifyResult (\r -> r{wrRegisters = writeF (wrRegisters r)})
Just _ -> lift $ harmless $ errorAt thing "Register was already set earlier"
setRegister :: WithOffset a -> SetRegister Address -> SWeed ()
setRegister thing (SetIAR a) = helpSetRegister thing rIAR (\r -> r{rIAR = Just a})
setRegister thing (SetACC a) = helpSetRegister thing rACC (\r -> r{rACC = Just a})
setRegister thing (SetRA a) = helpSetRegister thing rRA (\r -> r{rRA = Just a})
setRegister thing (SetSP a) = helpSetRegister thing rSP (\r -> r{rSP = Just a})
setRegister thing (SetFP a) = helpSetRegister thing rFP (\r -> r{rFP = Just a})
setAddressTo :: WithOffset a -> MimaAddress -> SWeed ()
setAddressTo thing addr = do
s@WeedState{..} <- get
if (addr > wsAt) || (not wsOccupied && addr == wsAt)
then put s{wsAt = addr, wsOccupied = False}
else lift $ harmless $ errorAt thing "Can only increase address"
addAlmostWord :: WithOffset a -> AlmostWord Address -> SWeed ()
addAlmostWord thing aw = do
addr <- toNextFree thing
modifyResult (\r -> r{wrMemory = Map.insert addr aw (wrMemory r)})
modify (\s -> s{wsOccupied = True})
addLabel :: WithOffset a -> LabelName -> SWeed ()
addLabel thing l = do
addr <- toNextFree thing
WeedState{..} <- get
case wrLabels wsResult Map.!? l of
Nothing -> modifyResult (\r -> r{wrLabels = Map.insert l addr (wrLabels r)})
Just _ -> lift $ harmless $ errorAt thing "Label was already defined earlier"
pushFlags :: Set.Set Char -> SWeed ()
pushFlags newFlags = do
WeedState{..} <- get
unless (Set.null wsOpenFlags) $ do
let r = range wsLastFlagsAt wsAt
modifyResult (\res -> res{wrFlags = Map.insert r wsOpenFlags (wrFlags res)})
modify (\st -> st{wsOpenFlags = newFlags, wsLastFlagsAt = wsAt})
setFlags :: WithOffset a -> Set.Set Char -> SWeed ()
setFlags thing flags = do
void $ toNextFree thing
WeedState{..} <- get
unless (flags `Set.isSubsetOf` wsOpenFlags) $ do
let withFlags = Set.union wsOpenFlags flags
pushFlags withFlags
pushFlags wsOpenFlags
turnFlagsOn :: WithOffset a -> Set.Set Char -> SWeed ()
turnFlagsOn thing flags = do
WeedState{..} <- get
let newFlags = Set.union wsOpenFlags flags
when (wsOpenFlags == newFlags) $
lift $ harmless $ errorAt thing "All flags already active at this address"
pushFlags newFlags
turnFlagsOff :: WithOffset a -> Set.Set Char -> SWeed ()
turnFlagsOff thing flags = do
WeedState{..} <- get
let newFlags = wsOpenFlags Set.\\ flags
when (wsOpenFlags == newFlags) $
lift $ harmless $ errorAt thing "All flags already inactive at this address"
pushFlags newFlags
{- Weeding at a larger scale -}
weedDirective :: WithOffset a -> Directive Address -> SWeed ()
weedDirective thing d = case d of
DReg sr -> setRegister thing sr
DOrg addr -> setAddressTo thing addr
DLit w -> addAlmostWord thing (ALiteral w)
DArr ws -> mapM_ (addAlmostWord thing . ALiteral) ws
DFlag flags -> setFlags thing flags
DFlagOn flags -> turnFlagsOn thing flags
DFlagOff flags -> turnFlagsOff thing flags
weedInstruction :: WithOffset a -> RawInstruction Address -> SWeed ()
weedInstruction thing i = addAlmostWord thing $ AInstruction i
weedStep :: WithOffset (Statement Address) -> SWeed ()
weedStep thing =
case woValue thing of
SDirective d -> weedDirective thing d
SRawInstruction i -> weedInstruction thing i
SLabel l -> addLabel thing l
weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address)
weedStatements statements = do
result <- execStateT (mapM_ weedStep statements) initialState
unless (Set.null $ wsOpenFlags result)
$ harmless
$ errorAt' (lastOffset statements)
$ "Flags were never closed: " ++ T.unpack (formatFlagSet (wsOpenFlags result))
pure $ wsResult result
where
-- Quick and dirty solution, plus I'm too lazy to see if the prelude has a
-- safe head
lastOffset [] = 0
lastOffset [s] = woOffset s
lastOffset (_:s) = lastOffset s

189
src/Mima/Parse/Common.hs
View file

@ -1,189 +0,0 @@
module Mima.Parse.Common
( Parser
-- * Character specifications
, isConnecting
, isWhitespace
-- * Basic parsers
, whitespace
, labelName
, flag
-- ** Number literals
, binDigit
, decDigit
, octDigit
, hexDigit
, binNumber
, decNumber
, octNumber
, hexNumber
, fixedWidthBin
, fixedWidthDec
, fixedWidthOct
, fixedWidthHex
-- ** MiMa types
, asWord
, asLargeValue
, asSmallValue
, fixedWidthHexAddress
) where
import Data.Char
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Void
import Text.Megaparsec
import Mima.Word
type Parser = Parsec Void T.Text
{- Character specifications -}
isConnecting :: Char -> Bool
isConnecting '_' = True
isConnecting '-' = True
isConnecting _ = False
isWhitespace :: Char -> Bool
isWhitespace '\n' = False
isWhitespace c = isSpace c
{- Basic parsers -}
whitespace :: Parser Char
whitespace = label "whitespace" $ satisfy isWhitespace
labelName :: Parser T.Text
labelName = label "label" $ do
t <- satisfy isAlpha
ts <- takeWhileP Nothing (\c -> isAlphaNum c || isConnecting c)
pure $ T.singleton t <> ts
flag :: Parser (Set.Set Char)
flag = label "alphanumeric character" $ Set.singleton <$> satisfy isAlphaNum
binDigit :: (Num a) => Parser a
binDigit = label "binary digit" $ token helper Set.empty
where
helper '0' = Just 0
helper '1' = Just 1
helper _ = Nothing
octDigit :: (Num a) => Parser a
octDigit = label "octal digit" $ token helper Set.empty
where
helper '0' = Just 0
helper '1' = Just 1
helper '2' = Just 2
helper '3' = Just 3
helper '4' = Just 4
helper '5' = Just 5
helper '6' = Just 6
helper '7' = Just 7
helper _ = Nothing
decDigit :: (Num a) => Parser a
decDigit = label "decimal digit" $ token helper Set.empty
where
helper '0' = Just 0
helper '1' = Just 1
helper '2' = Just 2
helper '3' = Just 3
helper '4' = Just 4
helper '5' = Just 5
helper '6' = Just 6
helper '7' = Just 7
helper '8' = Just 8
helper '9' = Just 9
helper _ = Nothing
hexDigit :: (Num a) => Parser a
hexDigit = label "hexadecimal digit" $ token (helper . toLower) Set.empty
where
helper '0' = Just 0
helper '1' = Just 1
helper '2' = Just 2
helper '3' = Just 3
helper '4' = Just 4
helper '5' = Just 5
helper '6' = Just 6
helper '7' = Just 7
helper '8' = Just 8
helper '9' = Just 9
helper 'a' = Just 10
helper 'b' = Just 11
helper 'c' = Just 12
helper 'd' = Just 13
helper 'e' = Just 14
helper 'f' = Just 15
helper _ = Nothing
accumulateToBase :: (Integral a) => a -> [a] -> a
accumulateToBase base = helper . reverse
where
helper [] = 0
helper [d] = d
helper (d:ds) = d + base * helper ds
binNumber :: (Integral a) => Parser a
binNumber = label "binary number" $ accumulateToBase 2 <$> some binDigit
octNumber :: (Integral a) => Parser a
octNumber = label "octal number" $ accumulateToBase 8 <$> some octDigit
decNumber :: (Integral a) => Parser a
decNumber = label "decimal number" $ accumulateToBase 10 <$> some decDigit
hexNumber :: (Integral a) => Parser a
hexNumber = label "hexadecimal number" $ accumulateToBase 16 <$> some hexDigit
fixedWidthWithExponent :: (Num a) => a -> Parser a -> Int -> Parser a
fixedWidthWithExponent e digit width = do
digits <- count width digit
pure $ helper $ reverse digits
where
helper [] = 0
helper (x:xs) = x + e * helper xs
fixedWidthBin :: (Num a) => Int -> Parser a
fixedWidthBin = fixedWidthWithExponent 2 binDigit
fixedWidthOct :: (Num a) => Int -> Parser a
fixedWidthOct = fixedWidthWithExponent 8 octDigit
fixedWidthDec :: (Num a) => Int -> Parser a
fixedWidthDec = fixedWidthWithExponent 10 decDigit
fixedWidthHex :: (Num a) => Int -> Parser a
fixedWidthHex = fixedWidthWithExponent 16 hexDigit
-- The 'try' below is necessary for the label to take effect if the parser
-- succeeds but the value is out of bounds. In that case, the do-block has
-- usually already consumed input, so the label wouldn't take effect.
asBoundedValue :: (Show a, Ord a) => a -> a -> Parser a -> Parser a
asBoundedValue lower upper parser =
label ("value within bounds " ++ show (lower, upper)) $ try $ do
value <- parser
if lower <= value && value <= upper
then pure value
else empty
asWord :: Parser Integer -> Parser MimaWord
asWord parser =
let bound = fromIntegral (maxBound :: MimaWord)
in fromIntegral <$> asBoundedValue (-bound) bound parser
asLargeValue :: Parser Integer -> Parser LargeValue
asLargeValue parser =
let bound = fromIntegral (maxBound :: LargeValue)
in fromIntegral <$> asBoundedValue (-bound) bound parser
asSmallValue :: Parser Integer -> Parser SmallValue
asSmallValue parser =
let bound = fromIntegral (maxBound :: SmallValue)
in fromIntegral <$> asBoundedValue (-bound) bound parser
fixedWidthHexAddress :: Parser MimaAddress
fixedWidthHexAddress = label "fixed-width hexadecimal address"
$ asLargeValue
$ fixedWidthHex 5

44
src/Mima/Parse/FlagFile.hs
View file

@ -1,44 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.FlagFile
( parseFlagFile
, readFlagFile
) where
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Text.Megaparsec
import Mima.Flag
import Mima.Parse.Common
import Mima.Parse.Lexeme
import Mima.Parse.Weed
import Mima.Word
lAddress :: Parser MimaAddress
lAddress = lexeme fixedWidthHexAddress
lFlags :: Parser (Set.Set Char)
lFlags = Set.unions <$> some (lexeme flag)
lAddressRange :: Parser AddressRange
lAddressRange = do
firstAddress <- lAddress
secondAddress <- (symbol "-" *> lAddress) <|> pure firstAddress
pure $ range firstAddress secondAddress
lLine :: Parser (AddressRange, Set.Set Char)
lLine = do
a <- lAddressRange
void $ symbol ":"
f <- lFlags
hidden lNewlines
pure (a, f)
parseFlagFile :: Parser RawFlags
parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof
readFlagFile :: FilePath -> T.Text -> Either WeedErrorBundle RawFlags
readFlagFile = parse parseFlagFile

30
src/Mima/Parse/Lexeme.hs
View file

@ -1,30 +0,0 @@
module Mima.Parse.Lexeme
( space
, lexeme
, symbol
, lNewline
, lNewlines
) where
import Control.Monad
import qualified Data.Text as T
import Text.Megaparsec
import qualified Text.Megaparsec.Char as C
import qualified Text.Megaparsec.Char.Lexer as L
import Mima.Parse.Common
space :: Parser ()
space = L.space (void whitespace) empty empty
lexeme :: Parser a -> Parser a
lexeme = L.lexeme space
symbol :: T.Text -> Parser T.Text
symbol = L.symbol space
lNewline :: Parser ()
lNewline = void $ lexeme C.newline
lNewlines :: Parser ()
lNewlines = void (some lNewline) <|> eof

72
src/Mima/Parse/SymbolFile.hs
View file

@ -1,72 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Parse.SymbolFile
( parseSymbolFile
, weedSymbolFile
, readSymbolFile
) where
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Text as T
import Text.Megaparsec
import Mima.Label
import Mima.Parse.Common
import Mima.Parse.Lexeme
import Mima.Parse.Weed
import Mima.Word
{- Parsing -}
lWhitespace :: Parser Char
lWhitespace = lexeme whitespace
lAddress :: Parser MimaAddress
lAddress = lexeme fixedWidthHexAddress
lLabels :: Parser [WithOffset LabelName]
lLabels = lexeme $ sepBy1 (withOffset labelName) lWhitespace
lLine :: Parser (MimaAddress, [WithOffset LabelName])
lLine = do
addr <- lAddress
void $ symbol ":"
labels <- lLabels
lNewlines
pure (addr, labels)
-- Does not keep the last list to appear for a certain key, but concatenates
-- them all.
combineLines :: [(MimaAddress, [WithOffset LabelName])]
-> Map.Map MimaAddress [WithOffset LabelName]
combineLines = ($ Map.empty) . mconcat . reverse . map (uncurry $ Map.insertWith (++))
parseSymbolFile :: Parser (Map.Map MimaAddress [WithOffset LabelName])
parseSymbolFile = space *> many lNewline *> (combineLines <$> many lLine) <* eof
{- Weeding -}
wBuildMap :: [(WithOffset LabelName, MimaAddress)] -> Weed WeedError LabelSpec
wBuildMap = foldM helper Map.empty
where
helper :: Map.Map LabelName MimaAddress
-> (WithOffset LabelName, MimaAddress)
-> Weed WeedError LabelSpec
helper m (l, addr)
| name `Map.member` m = do
harmless $ errorAt l "label was specified more than once"
pure m
| otherwise = pure $ Map.insert name addr m
where name = woValue l
weedSymbolFile :: Map.Map MimaAddress [WithOffset LabelName]
-> Weed WeedError LabelSpec
weedSymbolFile m =
let pairs = [(l, a) | (a, ls) <- Map.assocs m, l <- ls]
in wBuildMap pairs
readSymbolFile :: FilePath -> T.Text -> Either WeedErrorBundle LabelSpec
readSymbolFile filename input = do
unweeded <- parse parseSymbolFile filename input
runWeedBundle filename input $ weedSymbolFile unweeded

106
src/Mima/Parse/Weed.hs
View file

@ -1,106 +0,0 @@
module Mima.Parse.Weed
( Weed
, runWeed
, critical
, harmless
-- * Nice error messages
, defaultPosState
, WeedError
, WeedErrorBundle
-- ** Remembering an element's offset
, WithOffset(..)
, withOffset
, errorAt
, errorAt'
, errorsAt'
, runWeedBundle
) where
import qualified Data.List.NonEmpty as NE
import Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Void
import Text.Megaparsec
import Mima.Parse.Common
-- The star of the show
data Weed e a = Weed (Endo [e]) (Either e a)
instance Functor (Weed e) where
fmap f (Weed e a) = Weed e $ fmap f a
instance Applicative (Weed e) where
pure = Weed mempty . pure
(Weed es1 (Left e1)) <*> (Weed es2 (Left e2)) = Weed (es1 <> Endo (e1:) <> es2) (Left e2)
(Weed es1 f) <*> (Weed es2 a) = Weed (es1 <> es2) (f <*> a)
instance Monad (Weed e) where
(Weed es1 v) >>= f =
case f <$> v of
Left e -> Weed es1 (Left e)
Right (Weed es2 a) -> Weed (es1 <> es2) a
runWeed :: Weed e a -> Either (NE.NonEmpty e) a
-- Since the Endos never remove an element and we add an extra
-- element, this list is never empty.
--
-- I've tried to figure out nicer types for this, but if I want to
-- keep the Endo trick, the tradeoff isn't worth it. The problem here
-- is that I can't easily check if 'es' is 'mempty' with these
-- endofunctors.
runWeed (Weed es (Left e)) = Left $ NE.fromList $ appEndo es [e]
runWeed (Weed es (Right a)) =
case appEndo es [] of
(x:xs) -> Left $ x NE.:| xs
[] -> Right a
critical :: e -> Weed e a
critical e = Weed mempty (Left e)
harmless :: e -> Weed e ()
harmless e = Weed (Endo (e:)) (Right ())
{- Nice error messages -}
defaultPosState :: FilePath -> T.Text -> PosState T.Text
defaultPosState filename input = PosState
{ pstateInput = input
, pstateOffset = 0
, pstateSourcePos = initialPos filename
, pstateTabWidth = defaultTabWidth
, pstateLinePrefix = ""
}
type WeedError = ParseError T.Text Void
type WeedErrorBundle = ParseErrorBundle T.Text Void
data WithOffset a = WithOffset
{ woOffset :: Int
, woValue :: a
}
deriving (Show)
instance (Eq a) => Eq (WithOffset a) where
a == b = woValue a == woValue b
instance (Ord a) => Ord (WithOffset a) where
compare a b = compare (woValue a) (woValue b)
withOffset :: Parser a -> Parser (WithOffset a)
withOffset p = WithOffset <$> getOffset <*> p
errorAt :: WithOffset a -> String -> WeedError
errorAt wo = errorAt' (woOffset wo)
errorAt' :: Int -> String -> WeedError
errorAt' o errorMsg = errorsAt' o [errorMsg]
errorsAt' :: Int -> [String] -> WeedError
errorsAt' o = FancyError o . Set.fromList . map ErrorFail
runWeedBundle :: FilePath -> T.Text -> Weed WeedError a -> Either WeedErrorBundle a
runWeedBundle filename input w = case runWeed w of
Left errors -> Left $ ParseErrorBundle errors $ defaultPosState filename input
Right a -> Right a

195
src/Mima/State.hs
View file

@ -1,195 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Mima.State
( MimaMemory
, mapToMemory
, wordsToMemory
, memoryToWords
, maxAddress
, usedAddresses
, continuousUsedAddresses
, readAt
, writeAt
, MimaState(..)
, basicState
, AbortReason(..)
, step
, run
, 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
newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord)
deriving (Show)
mapToMemory :: Map.Map MimaAddress MimaWord -> MimaMemory
mapToMemory = MimaMemory . Map.filter (/= zeroBits)
wordsToMemory :: [MimaWord] -> MimaMemory
wordsToMemory = mapToMemory
. Map.fromAscList
. zip [minBound..]
memoryToWords :: MimaMemory -> [MimaWord]
memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem
maxAddress :: MimaMemory -> MimaAddress
maxAddress (MimaMemory m) = maybe minBound fst $ Map.lookupMax m
usedAddresses :: MimaMemory -> [MimaAddress]
usedAddresses (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
writeAt :: MimaAddress -> MimaWord -> MimaMemory -> MimaMemory
writeAt addr word (MimaMemory m)
| word == zeroBits = MimaMemory $ Map.delete addr m
| otherwise = MimaMemory $ Map.insert addr word m
data MimaState = MimaState
{ msIAR :: !MimaAddress
, msACC :: !MimaWord
, msRA :: !MimaAddress
, msSP :: !MimaAddress
, msFP :: !MimaAddress
, msMemory :: !MimaMemory
} deriving (Show)
basicState :: MimaMemory -> MimaState
basicState = MimaState zeroBits zeroBits zeroBits zeroBits zeroBits
data AbortReason
= Halted
| InvalidInstruction T.Text
| InvalidNextIarAddress
| AddressNotExecutable
| AddressReadOnly
deriving (Show)
instance ToText AbortReason where
toText Halted = "Halted"
toText (InvalidInstruction t) = "Exception: Invalid instruction: " <> t
toText InvalidNextIarAddress = "Exception: Can't increment IAR: Invalid next address"
toText AddressNotExecutable = "Exception: Address is not flagged as excutable"
toText AddressReadOnly = "Exception: Address is flagged as read-only"
{- 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 . throwE
incrementIAR :: MimaState -> Execution MimaState
incrementIAR ms =
let addr = msIAR ms
in if addr >= maxBound
then failWith InvalidNextIarAddress
else pure ms{msIAR = succ addr}
decodeInstruction :: MimaWord -> Execution Instruction
decodeInstruction word =
case wordToInstruction word of
Right instruction -> pure instruction
Left errorMsg -> failWith $ InvalidInstruction errorMsg
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)}
loadValue :: MimaAddress -> MimaState -> Execution MimaState
loadValue addr ms = pure ms{msACC = readAt addr (msMemory ms)}
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}
doLargeOpcode LDRA _ ms@MimaState{..} = pure ms{msACC = largeValueToWord msRA}
doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRA = getLargeValue msACC}
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{..} = 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
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 = helper 0
where
helper completed s =
case step' f s of
Left e -> (s, e, completed)
Right s' -> helper (completed + 1) s'
runN :: Flags (MimaAddress -> Bool) -> Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
runN f n = helper 0
where
helper completed s =
if completed >= n
then (s, Nothing, completed)
else case step' f s of
Left e -> (s, Just e, completed)
Right s' -> helper (completed + 1) s'

24
src/Mima/Util.hs
View file

@ -1,24 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
module Mima.Util
(
-- * Formatting
ToText(..)
) where
import qualified Data.Text as T
{- Formatting -}
-- | A class for types that can be converted to 'T.Text'.
--
-- This class does not mean to convert elements to text in a
-- standardized way. It is just to reduce the clutter of functions
-- with names like @somethingToText@.
--
-- Only create an instance of this class when there is an obvious,
-- preferrable way of converting something to text! If there are
-- multiple "obvious" options, create no instance of this class and
-- instead name the functions individually.
class ToText a where
toText :: a -> T.Text

7
src/Mima/Instruction.hs → src/Mima/Vm/Instruction.hs
View file

@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module Mima.Instruction
module Mima.Vm.Instruction
( SmallOpcode(..)
, LargeOpcode(..)
, argumentIsOptional
@ -12,9 +12,8 @@ module Mima.Instruction
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Mima.Format.Common
import Mima.Util
import Mima.Word
import Mima.Format
import Mima.Vm.Word
data SmallOpcode = LDC | LDV | STV | ADD | AND | OR | XOR | EQL
| JMP | JMN | LDIV | STIV | CALL | ADC

47
src/Mima/Vm/Memory.hs Normal file
View file

@ -0,0 +1,47 @@
module Mima.Vm.Memory
( MimaMemory
, mapToMemory
, wordsToMemory
, memoryToWords
, maxAddress
, usedAddresses
, continuousUsedAddresses
, readAt
, writeAt
) where
import Data.Bits
import qualified Data.Map.Strict as Map
import Mima.Vm.Word
newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord)
deriving (Show)
mapToMemory :: Map.Map MimaAddress MimaWord -> MimaMemory
mapToMemory = MimaMemory . Map.filter (/= zeroBits)
wordsToMemory :: [MimaWord] -> MimaMemory
wordsToMemory = mapToMemory
. Map.fromAscList
. zip [minBound..]
memoryToWords :: MimaMemory -> [MimaWord]
memoryToWords mem = map (`readAt` mem) $ continuousUsedAddresses mem
maxAddress :: MimaMemory -> MimaAddress
maxAddress (MimaMemory m) = maybe minBound fst $ Map.lookupMax m
usedAddresses :: MimaMemory -> [MimaAddress]
usedAddresses (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
writeAt :: MimaAddress -> MimaWord -> MimaMemory -> MimaMemory
writeAt addr word (MimaMemory m)
| word == zeroBits = MimaMemory $ Map.delete addr m
| otherwise = MimaMemory $ Map.insert addr word m

132
src/Mima/Vm/State.hs Normal file
View file

@ -0,0 +1,132 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Mima.Vm.State
( MimaState(..)
, basicState
, AbortReason(..)
, step
, run
, runN
) where
import Data.Bits
import qualified Data.Text as T
import Mima.Format
import Mima.Vm.Instruction
import Mima.Vm.Memory
import Mima.Vm.Word
data MimaState = MimaState
{ msIar :: !MimaAddress
, msAcc :: !MimaWord
, msRa :: !MimaAddress
, msSp :: !MimaAddress
, msFp :: !MimaAddress
, msMemory :: !MimaMemory
} deriving (Show)
basicState :: MimaMemory -> MimaState
basicState = MimaState zeroBits zeroBits zeroBits zeroBits zeroBits
data AbortReason
= Halted
| InvalidInstruction T.Text
| InvalidNextIarAddress
| AddressNotExecutable
| AddressReadOnly
deriving (Show)
instance ToText AbortReason where
toText Halted = "Halted"
toText (InvalidInstruction t) = "Exception: Invalid instruction: " <> t
toText InvalidNextIarAddress = "Exception: Can't increment IAR: Invalid next address"
toText AddressNotExecutable = "Exception: Address is not flagged as excutable"
toText AddressReadOnly = "Exception: Address is flagged as read-only"
{- A fancy monad that helps with stepping the MimaState -}
type Execution a = Either AbortReason a
incrementIar :: MimaState -> Execution MimaState
incrementIar ms
| addr >= maxBound = Left InvalidNextIarAddress
| otherwise = pure ms{msIar = succ addr}
where
addr = msIar ms
decodeInstruction :: MimaWord -> Execution Instruction
decodeInstruction word =
case wordToInstruction word of
Right instruction -> pure instruction
Left errorMsg -> Left $ InvalidInstruction errorMsg
storeValue :: MimaAddress -> MimaState -> Execution MimaState
storeValue addr ms = pure ms{msMemory = writeAt addr (msAcc ms) (msMemory ms)}
loadValue :: MimaAddress -> MimaState -> Execution MimaState
loadValue addr ms = pure ms{msAcc = readAt addr (msMemory ms)}
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 _ _ = Left 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}
doLargeOpcode LDRA _ ms@MimaState{..} = pure ms{msAcc = largeValueToWord msRa}
doLargeOpcode STRA _ ms@MimaState{..} = pure ms{msRa = getLargeValue msAcc}
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{..} = 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
step :: MimaState -> Execution MimaState
step ms = do
let addr = msIar ms
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'
run :: MimaState -> (MimaState, AbortReason, Integer)
run = helper 0
where
helper completed s =
case step s of
Left e -> (s, e, completed)
Right s' -> helper (completed + 1) s'
runN :: Integer -> MimaState -> (MimaState, Maybe AbortReason, Integer)
runN n = helper 0
where
helper completed s =
if completed >= n
then (s, Nothing, completed)
else case step s of
Left e -> (s, Just e, completed)
Right s' -> helper (completed + 1) s'

2
src/Mima/Word.hs → src/Mima/Vm/Word.hs
View file

@ -1,4 +1,4 @@
module Mima.Word
module Mima.Vm.Word
(
-- * Types
MimaWord

65
stack.yaml
View file

@ -1,68 +1,7 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-15.2
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
extra-deps:
- OddWord-1.0.2.0@sha256:5d848ff5db2c0457ce37ccc8898ce2b6b880a1c6a78e5b16841328a7404ff5ee,1888
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
- OddWord-1.0.2.0

2
stack.yaml.lock
View file

@ -10,7 +10,7 @@ packages:
size: 476
sha256: a4d203a05501dd71ee7f5af5f670f74361fdc28d88ffc4e0c39828c36d661e82
original:
hackage: OddWord-1.0.2.0@sha256:5d848ff5db2c0457ce37ccc8898ce2b6b880a1c6a78e5b16841328a7404ff5ee,1888
hackage: OddWord-1.0.2.0
snapshots:
- completed:
size: 491372

2
test/Spec.hs
View file

@ -1,2 +0,0 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"