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

VM: compile arithmetic commands

master
Denis Tereshkin 4 years ago
parent
74b8de3a48
commit
61295ef3a3
3 changed files with 178 additions and 40 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. 1
      nand2tetris.cabal
  2. 136
      src/Nand2Tetris/VM.hs
  3. 81
      test/Test/Nand2Tetris/VM.hs

1
nand2tetris.cabal
Unescape View File

@ -35,6 +35,7 @@ library
, text , text
, megaparsec , megaparsec
, containers , containers
, mtl
test-suite nand2tetris-test test-suite nand2tetris-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0

136
src/Nand2Tetris/VM.hs
Unescape View File

@ -1,5 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Nand2Tetris.VM module Nand2Tetris.VM
( (
@ -9,16 +9,26 @@ module Nand2Tetris.VM
Segment(..), Segment(..),
AnnotatedAsmLine(..), AnnotatedAsmLine(..),
parseInstruction, parseInstruction,
compileInstruction compileInstruction,
defaultCompilerEnv,
runCompiler,
runCompilerDef
) where ) where
import Nand2Tetris.Error ( Error ) import Control.Monad.State.Strict (State, evalState, gets, modify')
import Text.Megaparsec (Parsec, MonadParsec (try), (<|>), choice, many) import Data.Functor (($>))
import qualified Data.Text as T import qualified Data.Text as T
import Text.Megaparsec.Char (string, space1, letterChar, alphaNumChar, char) import Nand2Tetris.Error (Error)
import Data.Functor (($>)) 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 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 = data VMInstruction =
VMArithmetic ArithmeticCmd VMArithmetic ArithmeticCmd
@ -57,23 +67,25 @@ data Segment =
deriving (Show, Eq) deriving (Show, Eq)
instrAnnotation :: VMInstruction -> T.Text instrAnnotation :: VMInstruction -> T.Text
instrAnnotation (VMArithmetic i) = "" instrAnnotation (VMArithmetic ACAdd) = "add"
instrAnnotation (VMArithmetic ACSub) = "sub"
instrAnnotation (VMArithmetic ACNeg) = "neg"
instrAnnotation (VMMemAccess accessType segment) = instrAnnotation (VMMemAccess accessType segment) =
strAccessType <> " " <> strSegment strAccessType <> " " <> strSegment
where where
strAccessType = case accessType of strAccessType = case accessType of
ACPush -> "push" ACPush -> "push"
ACPop -> "pop" ACPop -> "pop"
strSegment = case segment of strSegment = case segment of
SLocal i -> "local " <> (T.pack . show $ i) SLocal i -> "local " <> (T.pack . show $ i)
SArgument i -> "argument " <> (T.pack . show $ i) SArgument i -> "argument " <> (T.pack . show $ i)
SThis i -> "this " <> (T.pack . show $ i) SThis i -> "this " <> (T.pack . show $ i)
SThat i -> "that " <> (T.pack . show $ i) SThat i -> "that " <> (T.pack . show $ i)
SConstant i -> "constant " <> (T.pack . show $ i) SConstant i -> "constant " <> (T.pack . show $ i)
SStatic label -> "static " <> label SStatic label -> "static " <> label
SPointer i -> "pointer " <> (T.pack . show $ i) SPointer i -> "pointer " <> (T.pack . show $ i)
STemp i -> "temp " <> (T.pack . show $ i) STemp i -> "temp " <> (T.pack . show $ i)
type Parser = Parsec Error T.Text type Parser = Parsec Error T.Text
@ -135,14 +147,41 @@ parseInstruction =
data AnnotatedAsmLine = data AnnotatedAsmLine =
Comment T.Text Comment T.Text
| Code HackInstruction | Code HackInstruction
| ALabel T.Text
deriving (Show, Eq) deriving (Show, Eq)
compileInstruction :: VMInstruction -> [AnnotatedAsmLine] data CompilerEnv = CompilerEnv
compileInstruction instr = {
Comment (instrAnnotation instr) : compileInstruction' instr 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 where
compileInstruction' (VMMemAccess ACPush segment) = compileInstruction' :: VMInstruction -> Compiler [AnnotatedAsmLine]
compileInstruction' (VMMemAccess ACPush segment) = return $
case segment of case segment of
SLocal offset -> pushSeq "LCL" offset SLocal offset -> pushSeq "LCL" offset
SArgument offset -> pushSeq "ARG" offset SArgument offset -> pushSeq "ARG" offset
@ -169,7 +208,7 @@ compileInstruction instr =
Code (A (Label "SP")), Code (A (Label "SP")),
Code (C [RegM] (SReg RegD) JNone) ] Code (C [RegM] (SReg RegD) JNone) ]
compileInstruction' (VMMemAccess ACPop segment) = compileInstruction' (VMMemAccess ACPop segment) = return $
case segment of case segment of
SLocal offset -> popSeq "LCL" offset SLocal offset -> popSeq "LCL" offset
SArgument offset -> popSeq "ARG" offset SArgument offset -> popSeq "ARG" offset
@ -180,6 +219,59 @@ compileInstruction instr =
SPointer offset -> if offset == 0 then popLabelValue "THIS" else popLabelValue "THAT" SPointer offset -> if offset == 0 then popLabelValue "THIS" else popLabelValue "THAT"
STemp offset -> popRam (5 + offset) 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 = [ pushLabelValue label = [
Code (A . Label $ label), Code (A . Label $ label),

81
test/Test/Nand2Tetris/VM.hs
Unescape View File

@ -14,7 +14,8 @@ import Nand2Tetris.VM (AccessType (ACPop, ACPush),
ArithmeticCmd (ACAdd, ACAnd, ACEq, ACGt, ACLt, ACNeg, ACNot, ACOr, ACSub), ArithmeticCmd (ACAdd, ACAnd, ACEq, ACGt, ACLt, ACNeg, ACNot, ACOr, ACSub),
Segment (SArgument, SConstant, SLocal, SPointer, SStatic, STemp, SThat, SThis), Segment (SArgument, SConstant, SLocal, SPointer, SStatic, STemp, SThat, SThis),
VMInstruction (VMArithmetic, VMMemAccess), VMInstruction (VMArithmetic, VMMemAccess),
compileInstruction, parseInstruction) compileInstruction, parseInstruction,
runCompilerDef)
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
@ -23,6 +24,7 @@ spec = do
describe "parseInstruction" parseInstructionSpec describe "parseInstruction" parseInstructionSpec
describe "compile push instruction" compilePushInstructionSpec describe "compile push instruction" compilePushInstructionSpec
describe "compile pop instruction" compilePopInstructionSpec describe "compile pop instruction" compilePopInstructionSpec
describe "compile arithmetic instrucitons" compileArithInstructionSpec
parseInstructionSpec :: Spec parseInstructionSpec :: Spec
parseInstructionSpec = do parseInstructionSpec = do
@ -89,27 +91,27 @@ parseInstructionSpec = do
compilePushInstructionSpec :: Spec compilePushInstructionSpec :: Spec
compilePushInstructionSpec = do compilePushInstructionSpec = do
it "Compiles push argument 42" $ 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") head compiled `shouldBe` (Comment "push argument 42")
tail compiled `shouldBe` pushValue "ARG" 42 tail compiled `shouldBe` pushValue "ARG" 42
it "Compiles push local 42" $ do 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") head compiled `shouldBe` (Comment "push local 42")
tail compiled `shouldBe` pushValue "LCL" 42 tail compiled `shouldBe` pushValue "LCL" 42
it "Compiles push this 41" $ do 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") head compiled `shouldBe` (Comment "push this 41")
tail compiled `shouldBe` pushValue "THIS" 41 tail compiled `shouldBe` pushValue "THIS" 41
it "Compiles push that 41" $ do 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") head compiled `shouldBe` (Comment "push that 41")
tail compiled `shouldBe` pushValue "THAT" 41 tail compiled `shouldBe` pushValue "THAT" 41
it "Compiles push constant 17" $ do 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") head compiled `shouldBe` (Comment "push constant 17")
tail compiled `shouldBe` [ tail compiled `shouldBe` [
Code (A (Imm 17)), Code (A (Imm 17)),
@ -122,22 +124,22 @@ compilePushInstructionSpec = do
Code (C [RegM] (SReg RegD) JNone) ] Code (C [RegM] (SReg RegD) JNone) ]
it "Compiles push static Foo.1" $ do 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") head compiled `shouldBe` (Comment "push static Foo.1")
tail compiled `shouldBe` pushLabel "Foo.1" tail compiled `shouldBe` pushLabel "Foo.1"
it "Compiles push pointer 0" $ do 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") head compiled `shouldBe` (Comment "push pointer 0")
tail compiled `shouldBe` pushLabel "THIS" tail compiled `shouldBe` pushLabel "THIS"
it "Compiles push pointer 1" $ do 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") head compiled `shouldBe` (Comment "push pointer 1")
tail compiled `shouldBe` pushLabel "THAT" tail compiled `shouldBe` pushLabel "THAT"
it "Compiles push temp 2" $ do 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") head compiled `shouldBe` (Comment "push temp 2")
tail compiled `shouldBe` pushRam (5 + 2) tail compiled `shouldBe` pushRam (5 + 2)
@ -177,42 +179,42 @@ compilePushInstructionSpec = do
compilePopInstructionSpec :: Spec compilePopInstructionSpec :: Spec
compilePopInstructionSpec = do compilePopInstructionSpec = do
it "pop argument 42" $ 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") head compiled `shouldBe` (Comment "pop argument 42")
tail compiled `shouldBe` popValue "ARG" 42 tail compiled `shouldBe` popValue "ARG" 42
it "pop local 42" $ do 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") head compiled `shouldBe` (Comment "pop local 42")
tail compiled `shouldBe` popValue "LCL" 42 tail compiled `shouldBe` popValue "LCL" 42
it "pop this 42" $ do 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") head compiled `shouldBe` (Comment "pop this 42")
tail compiled `shouldBe` popValue "THIS" 42 tail compiled `shouldBe` popValue "THIS" 42
it "pop that 42" $ do 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") head compiled `shouldBe` (Comment "pop that 42")
tail compiled `shouldBe` popValue "THAT" 42 tail compiled `shouldBe` popValue "THAT" 42
it "pop static Foo.1" $ do 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") head compiled `shouldBe` (Comment "pop static Foo.1")
tail compiled `shouldBe` popLabelValue "Foo.1" tail compiled `shouldBe` popLabelValue "Foo.1"
it "pop pointer 0" $ do 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") head compiled `shouldBe` (Comment "pop pointer 0")
tail compiled `shouldBe` popLabelValue "THIS" tail compiled `shouldBe` popLabelValue "THIS"
it "pop pointer 1" $ do 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") head compiled `shouldBe` (Comment "pop pointer 1")
tail compiled `shouldBe` popLabelValue "THAT" tail compiled `shouldBe` popLabelValue "THAT"
it "pop temp 1" $ do 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") head compiled `shouldBe` (Comment "pop temp 1")
tail compiled `shouldBe` popRam (5 + 1) tail compiled `shouldBe` popRam (5 + 1)
@ -249,3 +251,46 @@ compilePopInstructionSpec = do
Code (A . Imm $ offset), Code (A . Imm $ offset),
Code (C [RegM] (SReg RegD) JNone) ] 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)
]

Write Preview
Loading…
Cancel
Save