asakul
/
nand2tetris
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Refactoring 

Hack assembler definitions are now in separate module.
This will be handy when I implement VM compiler
master
Denis Tereshkin 4 years ago
parent
5b5887f2b5
commit
19d510bde8
4 changed files with 187 additions and 145 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 62
      app/HackAsm.hs
  2. 26
      hackasm.cabal
  3. 37
      nand2tetris.cabal
  4. 207
      src/Nand2Tetris/Hack.hs

62
app/HackAsm.hs
Unescape View File

@ -0,0 +1,62 @@
module Main (main) where
import Control.Monad (forM_)
import Data.Bits (testBit)
import Data.Foldable (foldl', foldr)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Nand2Tetris.Hack (AsmLine (LineInstruction), addLabels,
addVars, compile, defaultVars,
hackParser)
import Options.Applicative (execParser, fullDesc, header, help,
helper, info, long, metavar, progDesc,
short, strOption, (<**>))
import System.IO (IOMode (WriteMode), hPutStrLn, withFile)
import Text.Megaparsec (runParser)
import Text.Megaparsec.Error (ParseErrorBundle,
ShowErrorComponent (showErrorComponent),
errorBundlePretty)
data Options =
Options
{
inputFile :: FilePath,
outputFile :: FilePath
}
main :: IO ()
main = do
options <- execParser opts
programText <- TIO.readFile (inputFile options)
let result = runParser hackParser (inputFile options) programText
case result of
Left err -> putStrLn $ errorBundlePretty err
Right parsed -> do
let labels = addLabels M.empty parsed
let vars = addVars defaultVars labels parsed
print vars
let compiled = compile labels vars $ foldr addInstr [] parsed
case compiled of
Left err -> putStrLn $ "Error: " <> T.unpack err
Right program -> withFile (outputFile options) WriteMode $ \h -> forM_ program (\x -> hPutStrLn h (printInstruction x))
where
printInstruction w = concatMap (\x -> if testBit w x then "1" else "0") $ reverse [0..15]
regVars = defaultVars
addInstr (LineInstruction instr) is = instr : is
addInstr _ is = is
opts = info (hackAsmOptParser <**> helper)
( fullDesc
<> progDesc "Compiles a file with Hack assembly instructions to Hask binary code"
<> header "hackasm - assembler for hack CPU (nand2tetris)" )
hackAsmOptParser = Options <$>
strOption ( long "input"
<> short 'i'
<> metavar "FILENAME"
<> help "Input file" ) <*>
strOption ( long "output"
<> short 'o'
<> metavar "FILENAME"
<> help "Output file" )

26
hackasm.cabal
Unescape View File

@ -1,26 +0,0 @@
name: hackasm
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/githubuser/hackasm#readme
license: BSD3
license-file: LICENSE
author: Author name here
maintainer: example@example.com
copyright: 2021 Author name here
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md
executable hackasm
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, text
, megaparsec
, optparse-applicative
, containers
, bytestring
, binary

37
nand2tetris.cabal
Unescape View File

@ -0,0 +1,37 @@
name: nand2tetris
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://c.asakul.ru/asakul/nand2tetris
license: BSD3
license-file: LICENSE
author: Denis Tereshkin
maintainer: denis@kasan.ws
copyright: 2021 Denis Tereshkin
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md
executable hackasm
hs-source-dirs: app
main-is: HackAsm.hs
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, nand2tetris
, text
, megaparsec
, optparse-applicative
, containers
, bytestring
library
hs-source-dirs: src
default-language: Haskell2010
exposed-modules: Nand2Tetris.Hack
build-depends: base >= 4.7 && < 5
, text
, megaparsec
, containers

207
src/Main.hs → src/Nand2Tetris/Hack.hs
Unescape View File

@ -1,32 +1,44 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Nand2Tetris.Hack
module Main where (
HackInstruction(..),
import Data.Binary Imm(..),
import qualified Data.Map.Strict as M Reg(..),
import qualified Data.Text as T Source(..),
import qualified Data.Text.IO as TIO Jump(..),
import qualified Data.ByteString.Lazy as BL AsmLine(..),
import Text.Megaparsec (Parsec, runParserT, many, skipManyTill, runParser, some, errorBundlePretty, ShowErrorComponent, skipMany, notFollowedBy, MonadParsec (eof, lookAhead), choice, try, oneOf) hackParser,
import qualified Options.Applicative as O defaultVars,
import Options.Applicative (fullDesc, info, (<**>), helper, progDesc, header, strOption, long, metavar, help, execParser, short) compile,
import Control.Applicative hiding (many, some) LabelMap,
import Text.Megaparsec.Char (char, space, eol, alphaNumChar, letterChar, string, printChar, spaceChar, space1, string') Error(..),
import Text.Megaparsec.Error (ShowErrorComponent(showErrorComponent)) addVars,
import Text.Megaparsec.Debug addLabels
import Control.Monad (void, when, forM, forM_) ) where
import Text.Megaparsec.Char.Lexer (decimal, skipLineComment, symbol)
import Control.Monad (forM, when)
import Data.Bits (Bits (shift), (.|.))
import Data.Foldable (Foldable (foldl'))
import Data.Functor (($>))
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Word (Word16)
import Text.Megaparsec (MonadParsec (try), Parsec,
ShowErrorComponent, choice, empty,
eof, many, oneOf, optional,
skipManyTill, some, (<|>))
import Text.Megaparsec.Char (alphaNumChar, char, letterChar,
space, space1, string, string')
import Text.Megaparsec.Char.Lexer (decimal, skipLineComment)
import qualified Text.Megaparsec.Char.Lexer as L import qualified Text.Megaparsec.Char.Lexer as L
import Data.Maybe (catMaybes, fromMaybe) import Text.Megaparsec.Error (ShowErrorComponent(showErrorComponent))
import Text.Megaparsec.Byte.Lexer (symbol')
import Data.Foldable (Foldable(foldl'))
import Data.Word (Word16)
import Data.Bits ((.|.), Bits (shift, testBit))
import Debug.Trace
import GHC.IO.IOMode (IOMode(WriteMode))
import System.IO (withFile, hPutStrLn)
defaultVars :: LabelMap
defaultVars = M.fromList $ [("SP", 0), ("LCL", 1), ("ARG", 2), ("THIS", 3), ("THAT", 4)] <>
zip (fmap (\x -> "R" <> (T.pack . show $ x)) [0..15 :: Int]) [0..15 :: Int]
data HackInstruction = data HackInstruction =
A Imm A Imm
@ -76,7 +88,6 @@ data Error = ParsingError T.Text Int
instance ShowErrorComponent Error where instance ShowErrorComponent Error where
showErrorComponent = show showErrorComponent = show
type Parser = Parsec Error T.Text type Parser = Parsec Error T.Text
data AsmLine = data AsmLine =
@ -84,13 +95,6 @@ data AsmLine =
| LineLabel T.Text | LineLabel T.Text
deriving (Show, Eq) deriving (Show, Eq)
data Options =
Options
{
inputFile :: FilePath,
outputFile :: FilePath
}
hackParser :: Parser [AsmLine] hackParser :: Parser [AsmLine]
hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
where where
@ -117,13 +121,13 @@ hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
return . LineInstruction $ C (fromMaybe [] target) comp (fromMaybe JNone jump) return . LineInstruction $ C (fromMaybe [] target) comp (fromMaybe JNone jump)
parseReg :: Parser Reg parseReg :: Parser Reg
parseReg = try (char 'A' *> pure RegA) <|> try (char 'D' *> pure RegD) <|> try (char 'M' *> pure RegM) parseReg = try (char 'A' $> RegA) <|> try (char 'D' $> RegD) <|> try (char 'M' $> RegM)
parseComputation :: Parser Source parseComputation :: Parser Source
parseComputation = space >> parseComputation = space >>
(try $ char '0' *> pure S0) <|> (try $ char '0' $> S0) <|>
(try $ char '1' *> pure S1) <|> (try $ char '1' $> S1) <|>
(try $ string "-1" *> pure SNeg1) <|> (try $ string "-1" $> SNeg1) <|>
(try $ char '!' *> space *> parseReg >>= pure . SNot) <|> (try $ char '!' *> space *> parseReg >>= pure . SNot) <|>
(try $ char '-' *> space *> parseReg >>= pure . SNeg) <|> (try $ char '-' *> space *> parseReg >>= pure . SNeg) <|>
(try $ parseReg <* space <* char '+' <* space <* char '1' >>= pure . SRegPlus1) <|> (try $ parseReg <* space <* char '+' <* space <* char '1' >>= pure . SRegPlus1) <|>
@ -147,10 +151,11 @@ hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
| op == '&' -> | op == '&' ->
return $ if r1 == RegA || r2 == RegA then SDAndA else SDAndM return $ if r1 == RegA || r2 == RegA then SDAndA else SDAndM
| op == '|' -> | op == '|' ->
return $ if r1 == RegA || r2 == RegA then SDOrM else SDOrM return $ if r1 == RegA || r2 == RegA then SDOrA else SDOrM
| op == '-' && r1 == RegD -> return $ if r2 == RegA then SDMinusA else SDMinusM | op == '-' && r1 == RegD -> return $ if r2 == RegA then SDMinusA else SDMinusM
| op == '-' && r1 == RegA -> return SAMinusD | op == '-' && r1 == RegA -> return SAMinusD
| op == '-' && r1 == RegM -> return SMMinusD | op == '-' && r1 == RegM -> return SMMinusD
| otherwise -> fail "Invalid operands"
parseJump :: Parser Jump parseJump :: Parser Jump
parseJump = try $ do parseJump = try $ do
@ -175,25 +180,28 @@ hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
idParser :: Parser T.Text idParser :: Parser T.Text
idParser = T.pack <$> some (letterChar <|> oneOf ['.', '_', '$']) <> many alphaNumChar idParser = T.pack <$> some (letterChar <|> oneOf ['.', '_', '$']) <> many alphaNumChar
notEol :: Parser Char
notEol = skipManyTill (notFollowedBy eol) spaceChar
sp :: Parser () sp :: Parser ()
sp = L.space space1 (skipLineComment "//") empty sp = L.space space1 (skipLineComment "//") empty
type LabelMap = M.Map T.Text Int type LabelMap = M.Map T.Text Int
addLabels :: LabelMap -> [AsmLine] -> LabelMap
addLabels m parsed = snd $ foldl' addLabel (0, m) parsed
addVars :: LabelMap -> LabelMap -> [AsmLine] -> LabelMap
addVars m labels parsed = snd $ foldl' (addVar labels) (16, m) parsed
addLabel :: (Int, LabelMap) -> AsmLine -> (Int, LabelMap) addLabel :: (Int, LabelMap) -> AsmLine -> (Int, LabelMap)
addLabel (i, m) (LineInstruction _) = (i + 1, m) addLabel (i, m) (LineInstruction _) = (i + 1, m)
addLabel (i, m) (LineLabel v) = (i, M.insert v i m) addLabel (i, m) (LineLabel v) = (i, M.insert v i m)
addVars :: LabelMap -> (Int, LabelMap) -> AsmLine -> (Int, LabelMap) addVar :: LabelMap -> (Int, LabelMap) -> AsmLine -> (Int, LabelMap)
addVars labs (cnt, m) (LineInstruction (A (Label v))) = case M.lookup v labs of addVar labs (cnt, m) (LineInstruction (A (Label v))) = case M.lookup v labs of
Just _ -> (cnt, m) Just _ -> (cnt, m)
Nothing -> case M.lookup v m of Nothing -> case M.lookup v m of
Just _-> (cnt, m) Just _ -> (cnt, m)
Nothing -> (cnt + 1, M.insert v cnt m) Nothing -> (cnt + 1, M.insert v cnt m)
addVars _ m _ = m addVar _ m _ = m
compile :: LabelMap -> LabelMap -> [HackInstruction] -> Either T.Text [Word16] compile :: LabelMap -> LabelMap -> [HackInstruction] -> Either T.Text [Word16]
compile labels vars lines = forM lines compileInstruction compile labels vars lines = forM lines compileInstruction
@ -207,41 +215,41 @@ compile labels vars lines = forM lines compileInstruction
Just offset -> Right $ fromIntegral offset Just offset -> Right $ fromIntegral offset
Nothing -> case M.lookup l vars of Nothing -> case M.lookup l vars of
Just offset -> Right $ fromIntegral offset Just offset -> Right $ fromIntegral offset
Nothing -> Left $ "Invalid label: " <> l Nothing -> Left $ "Invalid label: " <> l
compileInstruction (C dest src jmp) = Right $ compileInstruction (C dest src jmp) = Right $
0xe000 .|. compileSourceOperand src .|. compileDestOperand dest .|. compileJump jmp 0xe000 .|. compileSourceOperand src .|. compileDestOperand dest .|. compileJump jmp
compileSourceOperand :: Source -> Word16 compileSourceOperand :: Source -> Word16
compileSourceOperand src = compileSourceOperand' src `shift` 6 compileSourceOperand src = compileSourceOperand' src `shift` 6
compileSourceOperand' S0 = 0x2a compileSourceOperand' S0 = 0x2a
compileSourceOperand' S1 = 0x3f compileSourceOperand' S1 = 0x3f
compileSourceOperand' SNeg1 = 0x3a compileSourceOperand' SNeg1 = 0x3a
compileSourceOperand' (SReg RegA) = 0x30 compileSourceOperand' (SReg RegA) = 0x30
compileSourceOperand' (SReg RegM) = 0x70 compileSourceOperand' (SReg RegM) = 0x70
compileSourceOperand' (SReg RegD) = 0x0c compileSourceOperand' (SReg RegD) = 0x0c
compileSourceOperand' (SNot RegA) = 0x31 compileSourceOperand' (SNot RegA) = 0x31
compileSourceOperand' (SNot RegM) = 0x71 compileSourceOperand' (SNot RegM) = 0x71
compileSourceOperand' (SNot RegD) = 0x0d compileSourceOperand' (SNot RegD) = 0x0d
compileSourceOperand' (SNeg RegA) = 0x33 compileSourceOperand' (SNeg RegA) = 0x33
compileSourceOperand' (SNeg RegM) = 0x73 compileSourceOperand' (SNeg RegM) = 0x73
compileSourceOperand' (SNeg RegD) = 0x0f compileSourceOperand' (SNeg RegD) = 0x0f
compileSourceOperand' (SRegPlus1 RegA) = 0x37 compileSourceOperand' (SRegPlus1 RegA) = 0x37
compileSourceOperand' (SRegPlus1 RegM) = 0x77 compileSourceOperand' (SRegPlus1 RegM) = 0x77
compileSourceOperand' (SRegPlus1 RegD) = 0x1f compileSourceOperand' (SRegPlus1 RegD) = 0x1f
compileSourceOperand' (SRegMinus1 RegA) = 0x32 compileSourceOperand' (SRegMinus1 RegA) = 0x32
compileSourceOperand' (SRegMinus1 RegM) = 0x72 compileSourceOperand' (SRegMinus1 RegM) = 0x72
compileSourceOperand' (SRegMinus1 RegD) = 0x0e compileSourceOperand' (SRegMinus1 RegD) = 0x0e
compileSourceOperand' SDPlusA = 0x02 compileSourceOperand' SDPlusA = 0x02
compileSourceOperand' SDPlusM = 0x42 compileSourceOperand' SDPlusM = 0x42
compileSourceOperand' SDMinusA = 0x13 compileSourceOperand' SDMinusA = 0x13
compileSourceOperand' SDMinusM = 0x53 compileSourceOperand' SDMinusM = 0x53
compileSourceOperand' SAMinusD = 0x07 compileSourceOperand' SAMinusD = 0x07
compileSourceOperand' SMMinusD = 0x47 compileSourceOperand' SMMinusD = 0x47
compileSourceOperand' SDAndA = 0x00 compileSourceOperand' SDAndA = 0x00
compileSourceOperand' SDAndM = 0x40 compileSourceOperand' SDAndM = 0x40
compileSourceOperand' SDOrA = 0x15 compileSourceOperand' SDOrA = 0x15
compileSourceOperand' SDOrM = 0x55 compileSourceOperand' SDOrM = 0x55
compileDestOperand dests = compileDestOperand' dests `shift` 3 compileDestOperand dests = compileDestOperand' dests `shift` 3
compileDestOperand' :: [Reg] -> Word16 compileDestOperand' :: [Reg] -> Word16
@ -253,49 +261,10 @@ compile labels vars lines = forM lines compileInstruction
compileDestBit b RegD = b .|. 2 compileDestBit b RegD = b .|. 2
compileJump JNone = 0 compileJump JNone = 0
compileJump JGt = 1 compileJump JGt = 1
compileJump JEq = 2 compileJump JEq = 2
compileJump JGe = 3 compileJump JGe = 3
compileJump JLt = 4 compileJump JLt = 4
compileJump JNe = 5 compileJump JNe = 5
compileJump JLe = 6 compileJump JLe = 6
compileJump Jmp = 7 compileJump Jmp = 7
main :: IO ()
main = do
options <- execParser opts
programText <- TIO.readFile (inputFile options)
let result = runParser hackParser (inputFile options) programText
case result of
Left err -> putStrLn $ errorBundlePretty err
Right parsed -> do
let labels = snd $ foldl' addLabel (0, M.empty) parsed
let vars = snd $ foldl' (addVars labels) (16, regVars) parsed
print vars
let compiled = compile labels vars $ foldr addInstr [] parsed
case compiled of
Left err -> putStrLn $ "Error: " <> T.unpack err
Right program -> withFile (outputFile options) WriteMode $ \h -> forM_ program (\x -> hPutStrLn h (printInstruction x))
where
printInstruction w = concatMap (\x -> if testBit w x then "1" else "0") $ reverse [0..15]
regVars = M.fromList $ [("SP", 0), ("LCL", 1), ("ARG", 2), ("THIS", 3), ("THAT", 4)] <>
zip (fmap (\x -> "R" <> (T.pack . show $ x)) [0..15 :: Int]) [0..15 :: Int]
addInstr (LineInstruction instr) is = instr : is
addInstr _ is = is
opts = info (hackAsmOptParser <**> helper)
( fullDesc
<> progDesc "Compiles a file with Hack assembly instructions to Hask binary code"
<> header "hackasm - assembler for hack CPU (nand2tetris)" )
hackAsmOptParser = Options <$>
strOption ( long "input"
<> short 'i'
<> metavar "FILENAME"
<> help "Input file" ) <*>
strOption ( long "output"
<> short 'o'
<> metavar "FILENAME"
<> help "Output file" )
Write Preview
Loading…
Cancel
Save