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
Split 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 @@ -35,6 +35,7 @@ library
, text
, megaparsec
, containers
, mtl
test-suite nand2tetris-test
type: exitcode-stdio-1.0

136
src/Nand2Tetris/VM.hs
Unescape View File

@ -1,5 +1,5 @@ @@ -1,5 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Nand2Tetris.VM
(
@ -9,16 +9,26 @@ 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 = @@ -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 = @@ -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 = @@ -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 = @@ -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),

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

@ -14,7 +14,8 @@ import Nand2Tetris.VM (AccessType (ACPop, ACPush), @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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)
]

Write Preview
Loading…
Cancel
Save