Load and save memory maps

package.yaml

@@ -19,11 +19,10 @@ extra-source-files:
 description:         Please see the README on GitHub at <https://github.com/Garmelon/mima-tools#readme>
 
 dependencies:
-- base       >= 4.7   && < 5
+- base       >= 4.7    && < 5
-- text       >= 1.2.3 && < 1.3
+- bytestring >= 0.10.8 && < 0.11
-- containers >= 0.6.0 && < 0.7
+- containers >= 0.6.0  && < 0.7
-# - array >= 0.5.3 && < 0.6
+- text       >= 1.2.3  && < 1.3
-# - binary >= 0.8.6 && < 0.9
 
 library:
   source-dirs: src

src/Mima/Load.hs

@@ -0,0 +1,39 @@
+module Mima.Load
+  ( loadMemoryFromFile
+  , saveMemoryToFile
+  ) where
+
+import           Data.Bits
+import qualified Data.ByteString as BS
+import           Data.Word
+
+import           Mima.Word
+import           Mima.State
+
+-- These two functions are implemented with explicit recursion. The
+-- first because it was easier to write that way, and the second in
+-- the hopes of better performance regarding list concatenation.
+
+bytesToWords :: [Word8] -> [MimaWord]
+bytesToWords (w1:w2:w3:ws) =  bytesToWord w1 w2 w3 : bytesToWords ws
+bytesToWords [w1,w2]       = [bytesToWord w1 w2       zeroBits]
+bytesToWords [w1]          = [bytesToWord w1 zeroBits zeroBits]
+bytesToWords []            = []
+
+wordsToBytes :: [MimaWord] -> [Word8]
+wordsToBytes []     = []
+wordsToBytes (w:ws) =
+  let (w1, w2, w3) = wordToBytes w
+  in  w1 : w2 : w3 : wordsToBytes ws
+
+bsToWords :: BS.ByteString -> [MimaWord]
+bsToWords = bytesToWords . BS.unpack
+
+wordsToBs :: [MimaWord] -> BS.ByteString
+wordsToBs = BS.pack . wordsToBytes
+
+loadMemoryFromFile :: FilePath -> IO MimaMemory
+loadMemoryFromFile path = (wordsToMemory . bsToWords) <$> BS.readFile path
+
+saveMemoryToFile :: FilePath -> MimaMemory -> IO ()
+saveMemoryToFile path = BS.writeFile path . wordsToBs . memoryToWords

src/Mima/State.hs

@@ -1,6 +1,7 @@
 module Mima.State
   ( MimaMemory
   , wordsToMemory
+  , memoryToWords
   , readAt
   , writeAt
   , MimaState(..)
@@ -12,6 +13,7 @@ module Mima.State
 
 import           Data.Bits
 import qualified Data.Map as Map
+import           Data.Maybe
 import qualified Data.Text as T
 
 import           Mima.Instruction
@@ -23,6 +25,11 @@ newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord)
 wordsToMemory :: [MimaWord] -> MimaMemory
 wordsToMemory = MimaMemory . Map.fromAscList . zip [minBound..]
 
+memoryToWords :: MimaMemory -> [MimaWord]
+memoryToWords mem@(MimaMemory m) =
+  let maxAddr = fromMaybe minBound $ fst <$> Map.lookupMax m
+  in  map (\addr -> readAt addr mem) [minBound..maxAddr]
+
 readAt :: MimaAddress -> MimaMemory -> MimaWord
 readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m
 
@@ -80,7 +87,7 @@ executeSmallOpcode ADD addr ms = incrementIp ms{msAcc = addWords (msAcc ms) (rea
 executeSmallOpcode AND addr ms = incrementIp ms{msAcc = msAcc ms .&.   readAt addr (msMemory ms)}
 executeSmallOpcode OR  addr ms = incrementIp ms{msAcc = msAcc ms .|.   readAt addr (msMemory ms)}
 executeSmallOpcode XOR addr ms = incrementIp ms{msAcc = msAcc ms `xor` readAt addr (msMemory ms)}
-executeSmallOpcode EQL addr ms = incrementIp ms{msAcc = wordFromBool $ msAcc ms == readAt addr (msMemory ms)}
+executeSmallOpcode EQL addr ms = incrementIp ms{msAcc = boolToWord $ msAcc ms == readAt addr (msMemory ms)}
 executeSmallOpcode JMP addr ms = pure ms{msIp = addr}
 executeSmallOpcode JMN addr ms = if topBit (msAcc ms) then pure ms{msIp = addr} else incrementIp ms
 

src/Mima/Word.hs

@@ -2,7 +2,9 @@
 
 module Mima.Word
   ( MimaWord
-  , wordFromBool
+  , bytesToWord
+  , wordToBytes
+  , boolToWord
   , topBit
   , upperOpcode
   , lowerOpcode
@@ -73,9 +75,24 @@ instance Bits MimaWord where
   isSigned = const True
   popCount = popCount . toWord32
 
-wordFromBool :: Bool -> MimaWord
+bytesToWord :: Word8 -> Word8 -> Word8 -> MimaWord
-wordFromBool False = zeroBits
+bytesToWord w1 w2 w3 =
-wordFromBool True  = complement zeroBits
+  let (w1', w2', w3') = (fromIntegral w1, fromIntegral w2, fromIntegral w3)
+  in  fromWord32 $ w1' .|. shiftL w2' 8 .|. shiftL w3' 16
+
+wordToBytes :: MimaWord -> (Word8, Word8, Word8)
+wordToBytes mw =
+  let w = toWord32 mw
+      -- Mask for w1 not strictly necessary, since upper bytes are
+      -- already zero due to implementation of 'fromWord32'.
+      w1 = fromIntegral $ shiftR w 16 .&. 0xFF 
+      w2 = fromIntegral $ shiftR w 8  .&. 0xFF
+      w3 = fromIntegral $          w  .&. 0xFF
+  in  (w1, w2, w3)
+
+boolToWord :: Bool -> MimaWord
+boolToWord False = zeroBits
+boolToWord True  = complement zeroBits
 
 topBit :: MimaWord -> Bool
 topBit mw = testBit (toWord32 mw) (wordSize - 1)