You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
548 lines
19 KiB
548 lines
19 KiB
{-# LANGUAGE MultiWayIf #-} |
|
{-# LANGUAGE OverloadedStrings #-} |
|
|
|
module Nand2Tetris.VM |
|
( |
|
VMInstruction(..), |
|
BranchingCmd(..), |
|
ArithmeticCmd(..), |
|
AccessType(..), |
|
Segment(..), |
|
AnnotatedAsmLine(..), |
|
parseInstruction, |
|
parseInstructions, |
|
compileInstruction, |
|
compileInstructions, |
|
defaultCompilerEnv, |
|
runCompiler, |
|
runCompilerDef, |
|
bootstrapPreamble |
|
) where |
|
|
|
import Control.Monad.State.Strict (State, evalState, forM, gets, |
|
modify') |
|
import Data.Functor (($>)) |
|
import Data.Maybe (fromMaybe) |
|
import qualified Data.Text as T |
|
import Nand2Tetris.Error (Error) |
|
import Nand2Tetris.Hack (HackInstruction (A, C), |
|
Imm (Imm, Label), |
|
Jump (JEq, JGt, JLt, JNe, JNone, Jmp), |
|
Reg (RegA, RegD, RegM), |
|
Source (S0, SDAndM, SDMinusA, SDOrM, SDPlusA, SDPlusM, SMMinusD, SNeg, SNeg1, SNot, SReg, SRegMinus1, SRegPlus1), |
|
canonicalRepresentation) |
|
import Text.Megaparsec (MonadParsec (try), Parsec, choice, |
|
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 = |
|
VMArithmetic ArithmeticCmd |
|
| VMMemAccess AccessType Segment |
|
| VMBranching BranchingCmd |
|
| VMFunction FunctionCmd |
|
deriving (Show, Eq) |
|
|
|
data FunctionCmd = |
|
FFunction T.Text Int |
|
| FCall T.Text Int |
|
| FReturn |
|
deriving (Show, Eq) |
|
|
|
data BranchingCmd = |
|
BLabel T.Text |
|
| BGoto T.Text |
|
| BIfGoto T.Text |
|
deriving (Show, Eq) |
|
|
|
data ArithmeticCmd = |
|
ACAdd |
|
| ACSub |
|
| ACNeg |
|
| ACEq |
|
| ACGt |
|
| ACLt |
|
| ACAnd |
|
| ACOr |
|
| ACNot |
|
deriving (Show, Eq) |
|
|
|
data AccessType = |
|
ACPush |
|
| ACPop |
|
deriving (Show, Eq) |
|
|
|
--newtype SegmentOffset = SegmentOffset { unSegmentOffset :: Int } |
|
-- deriving (Show, Eq) |
|
|
|
data Segment = |
|
SLocal Int |
|
| SArgument Int |
|
| SThis Int |
|
| SThat Int |
|
| SConstant Int |
|
| SStatic T.Text |
|
| SPointer Int |
|
| STemp Int |
|
deriving (Show, Eq) |
|
|
|
instrAnnotation :: VMInstruction -> T.Text |
|
instrAnnotation (VMArithmetic ACAdd) = "add" |
|
instrAnnotation (VMArithmetic ACSub) = "sub" |
|
instrAnnotation (VMArithmetic ACNeg) = "neg" |
|
instrAnnotation (VMArithmetic ACEq) = "eq" |
|
instrAnnotation (VMArithmetic ACGt) = "gt" |
|
instrAnnotation (VMArithmetic ACLt) = "lt" |
|
instrAnnotation (VMArithmetic ACAnd) = "and" |
|
instrAnnotation (VMArithmetic ACOr) = "or" |
|
instrAnnotation (VMArithmetic ACNot) = "not" |
|
instrAnnotation (VMMemAccess accessType segment) = |
|
strAccessType <> " " <> strSegment |
|
where |
|
strAccessType = case accessType of |
|
ACPush -> "push" |
|
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) |
|
SStatic label -> "static " <> label |
|
SPointer i -> "pointer " <> (T.pack . show $ i) |
|
STemp i -> "temp " <> (T.pack . show $ i) |
|
instrAnnotation (VMBranching (BLabel label)) = "label " <> label |
|
instrAnnotation (VMBranching (BGoto label)) = "goto " <> label |
|
instrAnnotation (VMBranching (BIfGoto label)) = "if-goto " <> label |
|
instrAnnotation (VMFunction (FFunction name nvars)) = "function " <> name <> " " <> (T.pack . show $ nvars) |
|
instrAnnotation (VMFunction (FCall name nargs)) = "call " <> name <> " " <> (T.pack . show $ nargs) |
|
instrAnnotation (VMFunction FReturn) = "return" |
|
|
|
type Parser = Parsec Error T.Text |
|
|
|
parseInstructions :: T.Text -> Parser [VMInstruction] |
|
parseInstructions modName = many (sp *> parseInstruction modName <* sp) <* eof |
|
where |
|
sp :: Parser () |
|
sp = L.space space1 (skipLineComment "//") empty |
|
|
|
parseInstruction :: T.Text -> Parser VMInstruction |
|
parseInstruction modName = |
|
try (parseMemAccess modName) <|> |
|
try parseArithmetic <|> |
|
try parseBranching <|> |
|
parseFunction |
|
|
|
where |
|
parseFunction :: Parser VMInstruction |
|
parseFunction = VMFunction <$> |
|
choice [ string "function" *> space1 *> (FFunction <$> (parseId <* space1) <*> L.decimal), |
|
string "call" *> space1 *> (FCall <$> (parseId <* space1) <*> L.decimal), |
|
string "return" $> FReturn |
|
] |
|
|
|
parseBranching :: Parser VMInstruction |
|
parseBranching = VMBranching <$> |
|
choice [ string "label" *> space1 *> (BLabel <$> parseId), |
|
string "goto" *> space1 *> (BGoto <$> parseId), |
|
string "if-goto" *> space1 *> (BIfGoto <$> parseId) |
|
] |
|
|
|
parseMemAccess :: T.Text -> Parser VMInstruction |
|
parseMemAccess modName = VMMemAccess <$> |
|
parseAccessType <*> |
|
parseSegment modName |
|
|
|
parseAccessType :: Parser AccessType |
|
parseAccessType = try (string "push" >> space1 $> ACPush) <|> |
|
(string "pop" >> space1 $> ACPop) |
|
|
|
parseSegment :: T.Text -> Parser Segment |
|
parseSegment modName = |
|
choice [ parseSegmentInt "local" SLocal, |
|
parseSegmentInt "argument" SArgument, |
|
parseSegmentInt "this" SThis, |
|
parseSegmentInt "that" SThat, |
|
parseSegmentInt "constant" SConstant, |
|
(string "static" *> space1) *> (SStatic <$> (try parseId <|> parseStaticOffset modName)), |
|
parseSegmentInt "pointer" SPointer, |
|
parseSegmentInt "temp" STemp |
|
] |
|
|
|
|
|
parseId :: Parser T.Text |
|
parseId = do |
|
h <- letterChar |
|
hs <- many (alphaNumChar <|> char '.' <|> char '_') |
|
return $ T.pack (h : hs) |
|
|
|
parseStaticOffset :: T.Text -> Parser T.Text |
|
parseStaticOffset modName = do |
|
h <- L.decimal |
|
return $ modName <> "." <> (T.pack . show) h |
|
|
|
parseSegmentInt :: T.Text -> (Int -> Segment) -> Parser Segment |
|
parseSegmentInt sname f = try $ do |
|
string sname |
|
space1 |
|
f <$> L.decimal |
|
|
|
parseArithmetic :: Parser VMInstruction |
|
parseArithmetic = VMArithmetic <$> |
|
choice [ string "add" $> ACAdd, |
|
string "sub" $> ACSub, |
|
string "neg" $> ACNeg, |
|
string "eq" $> ACEq, |
|
string "gt" $> ACGt, |
|
string "lt" $> ACLt, |
|
string "and" $> ACAnd, |
|
string "or" $> ACOr, |
|
string "not" $> ACNot |
|
] |
|
|
|
data AnnotatedAsmLine = |
|
Comment T.Text |
|
| Code HackInstruction |
|
| ALabel T.Text |
|
deriving (Show, Eq) |
|
|
|
data CompilerEnv = CompilerEnv |
|
{ |
|
ceLabelCounter :: Int, |
|
ceCurrentFunction :: Maybe T.Text |
|
} |
|
|
|
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 Nothing |
|
|
|
runCompiler :: CompilerEnv -> Compiler a -> a |
|
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) |
|
compiled <- compileInstruction' instr |
|
return $ ann : compiled |
|
|
|
where |
|
compileInstruction' :: VMInstruction -> Compiler [AnnotatedAsmLine] |
|
compileInstruction' (VMMemAccess ACPush segment) = return $ |
|
case segment of |
|
SLocal offset -> pushSeq "LCL" offset |
|
SArgument offset -> pushSeq "ARG" offset |
|
SThis offset -> pushSeq "THIS" offset |
|
SThat offset -> pushSeq "THAT" offset |
|
SConstant offset -> [ |
|
Code (A . Imm $ offset), |
|
Code (C [RegD] (SReg RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (C [RegD] (SRegPlus1 RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
SStatic label -> pushLabelValue label |
|
SPointer offset -> if offset == 0 then pushLabelValue "THIS" else pushLabelValue "THAT" |
|
STemp offset -> [ |
|
Code (A . Imm $ (5 + offset)), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (C [RegD] (SRegPlus1 RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
|
|
compileInstruction' (VMMemAccess ACPop segment) = return $ |
|
case segment of |
|
SLocal offset -> popSeq "LCL" offset |
|
SArgument offset -> popSeq "ARG" offset |
|
SThis offset -> popSeq "THIS" offset |
|
SThat offset -> popSeq "THAT" offset |
|
SConstant _ -> error "Pop constant instruction" |
|
SStatic label -> popLabelValue label |
|
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) |
|
compileInstruction' (VMBranching (BLabel label)) = do |
|
fname <- fromMaybe "_Global" <$> gets ceCurrentFunction |
|
return [ALabel $ fname <> "$" <> label] |
|
compileInstruction' (VMBranching (BGoto label)) = do |
|
fname <- fromMaybe "_Global" <$> gets ceCurrentFunction |
|
return [ Code (A (Label $ fname <> "$" <> label)), |
|
Code (C [] S0 Jmp) |
|
] |
|
compileInstruction' (VMBranching (BIfGoto label)) = do |
|
fname <- fromMaybe "_Global" <$> gets ceCurrentFunction |
|
return [ Code (A (Label "SP")), |
|
Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label $ fname <> "$" <> label)), |
|
Code (C [] (SReg RegD) JNe) |
|
] |
|
compileInstruction' (VMFunction (FFunction name nvars)) = do |
|
modify' (\s -> s { ceCurrentFunction = Just name }) |
|
return ([ ALabel name, |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone) |
|
] <> |
|
(concat . replicate nvars $ |
|
[ Code (C [RegM] S0 JNone), |
|
Code (C [RegA] (SRegPlus1 RegA) JNone) |
|
]) <> |
|
[ Code (C [RegD] (SReg RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] |
|
) |
|
|
|
compileInstruction' (VMFunction (FCall name nargs)) = do |
|
lab <- nextLabelId |
|
mbCurrentFunction <- gets ceCurrentFunction |
|
let labelId = |
|
case mbCurrentFunction of |
|
Just fname -> fname <> ".ret." <> lab |
|
Nothing -> lab |
|
return $ pushLabel labelId <> |
|
pushLabelValue "LCL" <> |
|
pushLabelValue "ARG" <> |
|
pushLabelValue "THIS" <> |
|
pushLabelValue "THAT" <> |
|
-- ARG = SP - 5 - nargs |
|
[ Code (A (Label "SP")), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Imm 5)), |
|
Code (C [RegD] SDMinusA JNone), |
|
Code (A (Imm nargs)), |
|
Code (C [RegD] SDMinusA JNone), |
|
Code (A (Label "ARG")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- LCL = SP |
|
[ Code (A (Label "SP")), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "LCL")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- goto function & and generate return label |
|
[ |
|
Code (A (Label name)), |
|
Code (C [] S0 Jmp), |
|
ALabel labelId |
|
] |
|
|
|
compileInstruction' (VMFunction FReturn) = do |
|
return $ |
|
-- endFrame (R15) = LCL |
|
[ Code (A (Label "LCL")), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Imm 15)), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- retAddr (R14) = *(endFrame - 5) |
|
[ Code (A (Imm 5)), |
|
Code (C [RegA] SDMinusA JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Imm 14)), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- *ARG = pop() |
|
[ Code (A (Label "SP")), |
|
Code (C [RegA] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "ARG")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- SP = ARG+1 |
|
[ Code (C [RegD] (SRegPlus1 RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- THAT = *(endFrame - 1), endFrame-- |
|
[ Code (A (Imm 15)), |
|
Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "THAT")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- THIS = *(endFrame - 1), endFrame-- |
|
[ Code (A (Imm 15)), |
|
Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "THIS")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- ARG = *(endFrame - 1), endFrame-- |
|
[ Code (A (Imm 15)), |
|
Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "ARG")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- ARG = *(endFrame - 1), endFrame-- |
|
[ Code (A (Imm 15)), |
|
Code (C [RegA, RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "LCL")), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] <> |
|
-- goto retAddr |
|
[ Code (A (Imm 14)), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [] S0 Jmp) |
|
] |
|
|
|
compileConditional jumpType = do |
|
let sub = binopSequence SMMinusD |
|
labEq <- nextLabelId |
|
labDone <- nextLabelId |
|
let rest = [ |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SRegMinus1 RegM) JNone), |
|
Code (C [RegD] (SReg 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) |
|
] |
|
|
|
pushLabel label = [ |
|
Code (A . Label $ label), |
|
Code (C [RegD] (SReg RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (C [RegD] (SRegPlus1 RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
|
|
pushLabelValue label = [ |
|
Code (A . Label $ label), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (C [RegD] (SRegPlus1 RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
|
|
pushSeq regName offset = [ |
|
Code (A . Imm $ offset), |
|
Code (C [RegD] (SReg RegA) JNone), |
|
Code (A (Label regName)), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegA] SDPlusA JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (C [RegD] (SRegPlus1 RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
|
|
|
|
popSeq regName offset = [ |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SRegMinus1 RegM) JNone), |
|
|
|
Code (A (Imm offset)), |
|
Code (C [RegD] (SReg RegA) JNone), |
|
Code (A (Label regName)), |
|
Code (C [RegD] SDPlusM JNone), |
|
Code (A (Imm 15)), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
|
|
Code (A (Label "SP")), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
Code (A (Imm 15)), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegM] (SReg RegD) JNone) |
|
] |
|
popLabelValue label = [ |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
|
|
Code (A . Label $ label), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
popRam offset = [ |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SRegMinus1 RegM) JNone), |
|
Code (C [RegA] (SReg RegM) JNone), |
|
Code (C [RegD] (SReg RegM) JNone), |
|
|
|
Code (A . Imm $ offset), |
|
Code (C [RegM] (SReg RegD) JNone) ] |
|
|
|
bootstrapPreamble :: [AnnotatedAsmLine] |
|
bootstrapPreamble = [ Comment "Bootstrap preamble", |
|
Code (A (Imm 261)), |
|
Code (C [RegD] (SReg RegA) JNone), |
|
Code (A (Label "SP")), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (A (Label "LCL")), |
|
Code (C [RegM] (SReg RegD) JNone), |
|
Code (A (Label "Sys.init")), |
|
Code (C [] S0 Jmp) |
|
]
|
|
|