From 61295ef3a3241c286c63515f54697a59eba624e1 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 19 Dec 2021 10:23:08 +0700 Subject: [PATCH] VM: compile arithmetic commands --- nand2tetris.cabal | 1 + src/Nand2Tetris/VM.hs | 136 ++++++++++++++++++++++++++++++------ test/Test/Nand2Tetris/VM.hs | 81 ++++++++++++++++----- 3 files changed, 178 insertions(+), 40 deletions(-) diff --git a/nand2tetris.cabal b/nand2tetris.cabal index af6ccf7..008d66f 100644 --- a/nand2tetris.cabal +++ b/nand2tetris.cabal @@ -35,6 +35,7 @@ library , text , megaparsec , containers + , mtl test-suite nand2tetris-test type: exitcode-stdio-1.0 diff --git a/src/Nand2Tetris/VM.hs b/src/Nand2Tetris/VM.hs index bc26942..bdc8d03 100644 --- a/src/Nand2Tetris/VM.hs +++ b/src/Nand2Tetris/VM.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiWayIf #-} module Nand2Tetris.VM ( @@ -9,16 +9,26 @@ module Nand2Tetris.VM Segment(..), AnnotatedAsmLine(..), parseInstruction, - compileInstruction + compileInstruction, + defaultCompilerEnv, + runCompiler, + runCompilerDef ) where -import Nand2Tetris.Error ( Error ) -import Text.Megaparsec (Parsec, MonadParsec (try), (<|>), choice, many) -import qualified Data.Text as T -import Text.Megaparsec.Char (string, space1, letterChar, alphaNumChar, char) -import Data.Functor (($>)) +import Control.Monad.State.Strict (State, evalState, gets, modify') +import Data.Functor (($>)) +import qualified Data.Text as T +import Nand2Tetris.Error (Error) +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)) +import Text.Megaparsec (MonadParsec (try), Parsec, choice, + many, (<|>)) +import Text.Megaparsec.Char (alphaNumChar, char, letterChar, + space1, string) import qualified Text.Megaparsec.Char.Lexer as L -import Nand2Tetris.Hack (HackInstruction (A, C), Imm (Label, Imm), Reg (RegD, RegA, RegM), Source (SReg, SDPlusA, SRegPlus1, SRegMinus1, SDPlusM), Jump (JNone)) data VMInstruction = VMArithmetic ArithmeticCmd @@ -57,23 +67,25 @@ data Segment = deriving (Show, Eq) instrAnnotation :: VMInstruction -> T.Text -instrAnnotation (VMArithmetic i) = "" +instrAnnotation (VMArithmetic ACAdd) = "add" +instrAnnotation (VMArithmetic ACSub) = "sub" +instrAnnotation (VMArithmetic ACNeg) = "neg" instrAnnotation (VMMemAccess accessType segment) = strAccessType <> " " <> strSegment where strAccessType = case accessType of ACPush -> "push" - ACPop -> "pop" + ACPop -> "pop" strSegment = case segment of - SLocal i -> "local " <> (T.pack . show $ i) - SArgument i -> "argument " <> (T.pack . show $ i) - SThis i -> "this " <> (T.pack . show $ i) - SThat i -> "that " <> (T.pack . show $ i) - SConstant i -> "constant " <> (T.pack . show $ i) + SLocal i -> "local " <> (T.pack . show $ i) + SArgument i -> "argument " <> (T.pack . show $ i) + SThis i -> "this " <> (T.pack . show $ i) + SThat i -> "that " <> (T.pack . show $ i) + SConstant i -> "constant " <> (T.pack . show $ i) SStatic label -> "static " <> label - SPointer i -> "pointer " <> (T.pack . show $ i) - STemp i -> "temp " <> (T.pack . show $ i) + SPointer i -> "pointer " <> (T.pack . show $ i) + STemp i -> "temp " <> (T.pack . show $ i) type Parser = Parsec Error T.Text @@ -135,14 +147,41 @@ parseInstruction = data AnnotatedAsmLine = Comment T.Text | Code HackInstruction + | ALabel T.Text deriving (Show, Eq) -compileInstruction :: VMInstruction -> [AnnotatedAsmLine] -compileInstruction instr = - Comment (instrAnnotation instr) : compileInstruction' instr +data CompilerEnv = CompilerEnv + { + ceLabelCounter :: Int + } + +type Compiler = State CompilerEnv + +nextLabelId :: Compiler T.Text +nextLabelId = do + v <- gets ceLabelCounter + modify' (\s -> s { ceLabelCounter = v + 1 }) + return $ "_VM_LABEL_" <> (T.pack . show) v + + +defaultCompilerEnv :: CompilerEnv +defaultCompilerEnv = CompilerEnv 0 + +runCompiler :: CompilerEnv -> Compiler a -> a +runCompiler = flip evalState + +runCompilerDef :: Compiler a -> a +runCompilerDef = runCompiler defaultCompilerEnv + +compileInstruction :: VMInstruction -> Compiler [AnnotatedAsmLine] +compileInstruction instr = do + let ann = Comment (instrAnnotation instr) + compiled <- compileInstruction' instr + return $ ann : compiled where - compileInstruction' (VMMemAccess ACPush segment) = + compileInstruction' :: VMInstruction -> Compiler [AnnotatedAsmLine] + compileInstruction' (VMMemAccess ACPush segment) = return $ case segment of SLocal offset -> pushSeq "LCL" offset SArgument offset -> pushSeq "ARG" offset @@ -169,7 +208,7 @@ compileInstruction instr = Code (A (Label "SP")), Code (C [RegM] (SReg RegD) JNone) ] - compileInstruction' (VMMemAccess ACPop segment) = + compileInstruction' (VMMemAccess ACPop segment) = return $ case segment of SLocal offset -> popSeq "LCL" offset SArgument offset -> popSeq "ARG" offset @@ -180,6 +219,59 @@ compileInstruction instr = SPointer offset -> if offset == 0 then popLabelValue "THIS" else popLabelValue "THAT" STemp offset -> popRam (5 + offset) + compileInstruction' (VMArithmetic ACAdd) = return $ binopSequence SDPlusM + compileInstruction' (VMArithmetic ACSub) = return $ binopSequence SMMinusD + compileInstruction' (VMArithmetic ACNeg) = return $ unopSequence (SNeg RegM) + compileInstruction' (VMArithmetic ACEq) = compileConditional JEq + compileInstruction' (VMArithmetic ACGt) = compileConditional JGt + compileInstruction' (VMArithmetic ACLt) = compileConditional JLt + compileInstruction' (VMArithmetic ACAnd) = return $ binopSequence SDAndM + compileInstruction' (VMArithmetic ACOr) = return $ binopSequence SDOrM + compileInstruction' (VMArithmetic ACNot) = return $ unopSequence (SNot RegM) + + compileConditional jumpType = do + let sub = binopSequence SMMinusD + labEq <- nextLabelId + labDone <- nextLabelId + let rest = [ + Code (A (Label "SP")), + Code (C [RegD] (SRegMinus1 RegM) JNone), + Code (A (Label labEq)), + Code (C [] (SReg RegD) jumpType), + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegM] S0 JNone), + Code (A (Label labDone)), + Code (C [] S0 Jmp), + + ALabel labEq, + + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegM] SNeg1 JNone), + + ALabel labDone + ] + return $ sub ++ rest + + unopSequence cmd = + [ + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegM] cmd JNone) + ] + + binopSequence cmd = + [ + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegD] (SReg RegM) JNone), + Code (C [RegA] (SRegMinus1 RegA) JNone), + Code (C [RegM] cmd JNone), + Code (C [RegD] (SRegPlus1 RegA) JNone), + Code (A (Label "SP")), + Code (C [RegM] (SReg RegD) JNone) + ] pushLabelValue label = [ Code (A . Label $ label), diff --git a/test/Test/Nand2Tetris/VM.hs b/test/Test/Nand2Tetris/VM.hs index 230a871..86adcbb 100644 --- a/test/Test/Nand2Tetris/VM.hs +++ b/test/Test/Nand2Tetris/VM.hs @@ -14,7 +14,8 @@ import Nand2Tetris.VM (AccessType (ACPop, ACPush), ArithmeticCmd (ACAdd, ACAnd, ACEq, ACGt, ACLt, ACNeg, ACNot, ACOr, ACSub), Segment (SArgument, SConstant, SLocal, SPointer, SStatic, STemp, SThat, SThis), VMInstruction (VMArithmetic, VMMemAccess), - compileInstruction, parseInstruction) + compileInstruction, parseInstruction, + runCompilerDef) import Text.Megaparsec (runParser) @@ -23,6 +24,7 @@ spec = do describe "parseInstruction" parseInstructionSpec describe "compile push instruction" compilePushInstructionSpec describe "compile pop instruction" compilePopInstructionSpec + describe "compile arithmetic instrucitons" compileArithInstructionSpec parseInstructionSpec :: Spec parseInstructionSpec = do @@ -89,27 +91,27 @@ parseInstructionSpec = do compilePushInstructionSpec :: Spec compilePushInstructionSpec = do it "Compiles push argument 42" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SArgument 42)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SArgument 42)) head compiled `shouldBe` (Comment "push argument 42") tail compiled `shouldBe` pushValue "ARG" 42 it "Compiles push local 42" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SLocal 42)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SLocal 42)) head compiled `shouldBe` (Comment "push local 42") tail compiled `shouldBe` pushValue "LCL" 42 it "Compiles push this 41" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SThis 41)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SThis 41)) head compiled `shouldBe` (Comment "push this 41") tail compiled `shouldBe` pushValue "THIS" 41 it "Compiles push that 41" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SThat 41)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SThat 41)) head compiled `shouldBe` (Comment "push that 41") tail compiled `shouldBe` pushValue "THAT" 41 it "Compiles push constant 17" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SConstant 17)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SConstant 17)) head compiled `shouldBe` (Comment "push constant 17") tail compiled `shouldBe` [ Code (A (Imm 17)), @@ -122,22 +124,22 @@ compilePushInstructionSpec = do Code (C [RegM] (SReg RegD) JNone) ] it "Compiles push static Foo.1" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SStatic "Foo.1")) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SStatic "Foo.1")) head compiled `shouldBe` (Comment "push static Foo.1") tail compiled `shouldBe` pushLabel "Foo.1" it "Compiles push pointer 0" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SPointer 0)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SPointer 0)) head compiled `shouldBe` (Comment "push pointer 0") tail compiled `shouldBe` pushLabel "THIS" it "Compiles push pointer 1" $ do - let compiled = compileInstruction (VMMemAccess ACPush (SPointer 1)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (SPointer 1)) head compiled `shouldBe` (Comment "push pointer 1") tail compiled `shouldBe` pushLabel "THAT" it "Compiles push temp 2" $ do - let compiled = compileInstruction (VMMemAccess ACPush (STemp 2)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPush (STemp 2)) head compiled `shouldBe` (Comment "push temp 2") tail compiled `shouldBe` pushRam (5 + 2) @@ -177,42 +179,42 @@ compilePushInstructionSpec = do compilePopInstructionSpec :: Spec compilePopInstructionSpec = do it "pop argument 42" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SArgument 42)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SArgument 42)) head compiled `shouldBe` (Comment "pop argument 42") tail compiled `shouldBe` popValue "ARG" 42 it "pop local 42" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SLocal 42)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SLocal 42)) head compiled `shouldBe` (Comment "pop local 42") tail compiled `shouldBe` popValue "LCL" 42 it "pop this 42" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SThis 42)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SThis 42)) head compiled `shouldBe` (Comment "pop this 42") tail compiled `shouldBe` popValue "THIS" 42 it "pop that 42" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SThat 42)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SThat 42)) head compiled `shouldBe` (Comment "pop that 42") tail compiled `shouldBe` popValue "THAT" 42 it "pop static Foo.1" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SStatic "Foo.1")) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SStatic "Foo.1")) head compiled `shouldBe` (Comment "pop static Foo.1") tail compiled `shouldBe` popLabelValue "Foo.1" it "pop pointer 0" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SPointer 0)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SPointer 0)) head compiled `shouldBe` (Comment "pop pointer 0") tail compiled `shouldBe` popLabelValue "THIS" it "pop pointer 1" $ do - let compiled = compileInstruction (VMMemAccess ACPop (SPointer 1)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (SPointer 1)) head compiled `shouldBe` (Comment "pop pointer 1") tail compiled `shouldBe` popLabelValue "THAT" it "pop temp 1" $ do - let compiled = compileInstruction (VMMemAccess ACPop (STemp 1)) + let compiled = runCompilerDef $ compileInstruction (VMMemAccess ACPop (STemp 1)) head compiled `shouldBe` (Comment "pop temp 1") tail compiled `shouldBe` popRam (5 + 1) @@ -249,3 +251,46 @@ compilePopInstructionSpec = do Code (A . Imm $ offset), Code (C [RegM] (SReg RegD) JNone) ] + +compileArithInstructionSpec :: Spec +compileArithInstructionSpec = do + it "compiles add" $ do + let compiled = runCompilerDef $ compileInstruction (VMArithmetic ACAdd) + head compiled `shouldBe` (Comment "add") + tail compiled `shouldBe` + [ + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegD] (SReg RegM) JNone), + Code (C [RegA] (SRegMinus1 RegA) JNone), + Code (C [RegM] SDPlusM JNone), + Code (C [RegD] (SRegPlus1 RegA) JNone), + Code (A (Label "SP")), + Code (C [RegM] (SReg RegD) JNone) + ] + + it "compiles sub" $ do + let compiled = runCompilerDef $ compileInstruction (VMArithmetic ACSub) + head compiled `shouldBe` (Comment "sub") + tail compiled `shouldBe` + [ + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegD] (SReg RegM) JNone), + Code (C [RegA] (SRegMinus1 RegA) JNone), + Code (C [RegM] SMMinusD JNone), + Code (C [RegD] (SRegPlus1 RegA) JNone), + Code (A (Label "SP")), + Code (C [RegM] (SReg RegD) JNone) + ] + + it "compiles neg" $ do + let compiled = runCompilerDef $ compileInstruction (VMArithmetic ACNeg) + head compiled `shouldBe` (Comment "neg") + tail compiled `shouldBe` + [ + Code (A (Label "SP")), + Code (C [RegA] (SRegMinus1 RegM) JNone), + Code (C [RegM] (SNeg RegM) JNone) + ] +