From 57bd5979e27e67b3eb53eb945eb6edd9d953aa6b Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 19 Dec 2021 11:11:55 +0700 Subject: [PATCH] new executable vmcompiler: compiles vm code to hack assembly --- app/VMCompiler.hs | 54 +++++++++++++++++++++++++++++++++++++++++ nand2tetris.cabal | 12 +++++++++ src/Nand2Tetris/Hack.hs | 49 ++++++++++++++++++++++++++++++++++++- src/Nand2Tetris/VM.hs | 20 ++++++++++++--- 4 files changed, 131 insertions(+), 4 deletions(-) create mode 100644 app/VMCompiler.hs diff --git a/app/VMCompiler.hs b/app/VMCompiler.hs new file mode 100644 index 0000000..bc4a4b1 --- /dev/null +++ b/app/VMCompiler.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Monad (forM_) +import qualified Data.Text.IO as TIO +import Nand2Tetris.Hack (AsmLine (..), HackInstruction (..), + canonicalRepresentation) +import Nand2Tetris.VM (AnnotatedAsmLine (..), + compileInstructions, parseInstructions) +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 parseInstructions (inputFile options) programText + case result of + Left err -> putStrLn $ errorBundlePretty err + Right parsed -> do + let compiled = compileInstructions parsed + withFile (outputFile options) WriteMode $ \h -> forM_ compiled (\x -> TIO.hPutStrLn h (printLine x)) + where + printLine (Comment t) = "// " <> t + printLine (Code i) = canonicalRepresentation (LineInstruction i) + printLine (ALabel l) = canonicalRepresentation (LineLabel l) + + opts = info (hackAsmOptParser <**> helper) + ( fullDesc + <> progDesc "Compiles Hack VM code to Hack assembly" + <> header "vmcompiler - Hack VM compiler (nand2tetris)" ) + hackAsmOptParser = Options <$> + strOption ( long "input" + <> short 'i' + <> metavar "FILENAME" + <> help "Input file" ) <*> + strOption ( long "output" + <> short 'o' + <> metavar "FILENAME" + <> help "Output file" ) diff --git a/nand2tetris.cabal b/nand2tetris.cabal index 008d66f..d907c11 100644 --- a/nand2tetris.cabal +++ b/nand2tetris.cabal @@ -25,6 +25,18 @@ executable hackasm , containers , bytestring +executable vmcompiler + hs-source-dirs: app + main-is: VMCompiler.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 diff --git a/src/Nand2Tetris/Hack.hs b/src/Nand2Tetris/Hack.hs index 09a7557..992d681 100644 --- a/src/Nand2Tetris/Hack.hs +++ b/src/Nand2Tetris/Hack.hs @@ -15,7 +15,8 @@ module Nand2Tetris.Hack LabelMap, Error(..), addVars, - addLabels + addLabels, + canonicalRepresentation ) where import Control.Monad (forM, when) @@ -95,6 +96,52 @@ data AsmLine = | LineLabel T.Text deriving (Show, Eq) +canonicalRepresentation :: AsmLine -> T.Text +canonicalRepresentation (LineLabel t) = "(" <> t <> ")" +canonicalRepresentation (LineInstruction (A (Label t))) = "@" <> t +canonicalRepresentation (LineInstruction (A (Imm v))) = "@" <> (T.pack . show) v +canonicalRepresentation (LineInstruction (C dest src jmp)) = destRepr <> srcRepr src <> jmpRepr + where + regRepr RegM = "M" + regRepr RegA = "A" + regRepr RegD = "D" + + destRepr = if null dest + then "" + else T.pack (concatMap regRepr dest) <> "=" + + srcRepr S0 = "0" + srcRepr S1 = "1" + srcRepr SNeg1 = "-1" + srcRepr (SReg r) = regRepr r + srcRepr (SNot r) = "!" <> regRepr r + srcRepr (SNeg r) = "-" <> regRepr r + srcRepr (SRegPlus1 r) = regRepr r <> "+1" + srcRepr (SRegMinus1 r) = regRepr r <> "-1" + srcRepr SDPlusA = "D+A" + srcRepr SDPlusM = "D+M" + srcRepr SDMinusA = "D-A" + srcRepr SDMinusM = "D-M" + srcRepr SAMinusD = "A-D" + srcRepr SMMinusD = "M-D" + srcRepr SDAndA = "D&A" + srcRepr SDAndM = "D&M" + srcRepr SDOrA = "D|A" + srcRepr SDOrM = "D|M" + + jmpRepr = if jmp == JNone + then "" + else "; " <> jmpRepr' jmp + + jmpRepr' JNone = "" + jmpRepr' JGt = "JGT" + jmpRepr' JEq = "JEQ" + jmpRepr' JGe = "JGE" + jmpRepr' JLt = "JLT" + jmpRepr' JNe = "JNE" + jmpRepr' JLe = "JLE" + jmpRepr' Jmp = "JMP" + hackParser :: Parser [AsmLine] hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof where diff --git a/src/Nand2Tetris/VM.hs b/src/Nand2Tetris/VM.hs index c298467..33fa744 100644 --- a/src/Nand2Tetris/VM.hs +++ b/src/Nand2Tetris/VM.hs @@ -9,13 +9,16 @@ module Nand2Tetris.VM Segment(..), AnnotatedAsmLine(..), parseInstruction, + parseInstructions, compileInstruction, + compileInstructions, defaultCompilerEnv, runCompiler, runCompilerDef ) where -import Control.Monad.State.Strict (State, evalState, gets, modify') +import Control.Monad.State.Strict (State, evalState, forM, gets, + modify') import Data.Functor (($>)) import qualified Data.Text as T import Nand2Tetris.Error (Error) @@ -23,11 +26,13 @@ import Nand2Tetris.Hack (HackInstruction (A, C), Imm (Imm, Label), Jump (JEq, JGt, JLt, JNone, Jmp), Reg (RegA, RegD, RegM), - Source (S0, SDAndM, SDOrM, SDPlusA, SDPlusM, SMMinusD, SNeg, SNeg1, SNot, SReg, SRegMinus1, SRegPlus1)) + Source (S0, SDAndM, SDOrM, SDPlusA, SDPlusM, SMMinusD, SNeg, SNeg1, SNot, SReg, SRegMinus1, SRegPlus1), + canonicalRepresentation) import Text.Megaparsec (MonadParsec (try), Parsec, choice, - many, (<|>)) + empty, eof, many, (<|>)) import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, string) +import Text.Megaparsec.Char.Lexer (skipLineComment) import qualified Text.Megaparsec.Char.Lexer as L data VMInstruction = @@ -96,6 +101,12 @@ instrAnnotation (VMMemAccess accessType segment) = type Parser = Parsec Error T.Text +parseInstructions :: Parser [VMInstruction] +parseInstructions = many (sp *> parseInstruction <* sp) <* eof + where + sp :: Parser () + sp = L.space space1 (skipLineComment "//") empty + parseInstruction :: Parser VMInstruction parseInstruction = try parseMemAccess <|> @@ -179,6 +190,9 @@ runCompiler = flip evalState runCompilerDef :: Compiler a -> a runCompilerDef = runCompiler defaultCompilerEnv +compileInstructions :: [VMInstruction] -> [AnnotatedAsmLine] +compileInstructions instrs = concat $ runCompilerDef (forM instrs compileInstruction) + compileInstruction :: VMInstruction -> Compiler [AnnotatedAsmLine] compileInstruction instr = do let ann = Comment (instrAnnotation instr)