diff options
Diffstat (limited to 'projects/11/JackCompiler.hs')
| -rw-r--r-- | projects/11/JackCompiler.hs | 538 |
1 files changed, 0 insertions, 538 deletions
diff --git a/projects/11/JackCompiler.hs b/projects/11/JackCompiler.hs deleted file mode 100644 index bf3acfe..0000000 --- a/projects/11/JackCompiler.hs +++ /dev/null @@ -1,538 +0,0 @@ --- Jack Compiler, as the coursework of Project 11 of Nand2Tetris course. --- Author: Yuchen Pei (me@ypei.me) --- Date: 2018-01-15 -{-# LANGUAGE FlexibleContexts #-} -import Text.Parsec.Prim -import Text.Parsec.Char -import Text.Parsec.Combinator -import Data.Functor.Identity -import Data.Either -import Data.Maybe -import Data.List -import System.Environment -import System.Directory -import Control.Monad -import Data.Char -import Data.Map (Map) -import qualified Data.Map as Map -import Debug.Trace - -data JClass = JClass JIdentifier [JClassVarDec] [JSubroutineDec] deriving (Show, Eq) -data JClassVarDec = JClassVarDec JClassVarScope JTypeAndId deriving (Show, Eq) -data JSubroutineDec = JSubroutineDec JSubroutineHeader JSubroutineBody deriving (Show, Eq) -data JSubroutineHeader = JSubroutineHeader JSubroutineType JTypeAndId [JTypeAndId] deriving (Show, Eq) -data JSubroutineBody = JSubroutineBody [JTypeAndId] [JStatement] deriving (Show, Eq) -data JStatement = JLetStatment JVarId JExpression - | JIfStatement JExpression [JStatement] (Maybe [JStatement]) - | JWhileStatment JExpression [JStatement] - | JDoStatement JSubroutineCall - | JReturnStatement (Maybe JExpression) - deriving (Show, Eq) -data JExpression = JIntConst Int - | JStrConst [Char] - | JKeywordConst [Char] -- can only be true, false, null or this - | JExpVar JVarId - | JExpCall JSubroutineCall - | JExpUna JUOp JExpression -- JOp can only be - or ~ here - | JExpBin JExpression [(JBOp, JExpression)] - deriving (Show, Eq) -data JVarId = JVarId JIdentifier (Maybe JExpression) deriving (Show, Eq) -data JSubroutineCall = JSubroutineCall JIdentifier (Maybe JIdentifier) [JExpression] deriving (Show, Eq) - ---data ClassTable = C [Char] Table Int deriving (Show, Eq) -type JBOp = Char -type JUOp = Char -type JIdentifier = [Char] -type JTypeAndId = (JType, JIdentifier) -type JClassVarScope = [Char] -type JType = [Char] -type JSubroutineType = [Char] -type JackParser = Parsec [Char] () --- For variable tables: map name (type, (seg, n)) --- For the subroutine table: map name (kind, (type, nArgs)) -type Table = Map [Char] ([Char], ([Char], Int)) - - -binaryOpChars = "+-*/&|<>=" -unaryOpChars = "-~" -keywordConstStrs = ["true", "false", "null", "this"] -primTypeStrs = ["int", "char", "boolean"] -primTypeStrs' = primTypeStrs ++ ["void"] -classVarScopeStrs = ["static", "field"] -subroutineTypeStrs = ["constructor", "function", "method"] -alphaUnderscore = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['_'] -alphaNumUnderscore = alphaUnderscore ++ ['0'..'9'] -alphaNumUnderscoredot = '.':alphaNumUnderscore - -parse' parser = parse parser "" - -jackReader = parse' (many jSpace >> jClass) - -jClass :: JackParser JClass -jClass = do - string "class" >> many1 jSpace - id <- jIdentifier - many jSpace >> char '{' - classVarDecs <- many $ try (many jSpace >> jClassVarDecs) - subroutineDecs <- many $ try (many jSpace >> jSubroutineDec) - many jSpace >> char '}' - return $ JClass id (mconcat classVarDecs) subroutineDecs - -jClassType :: JackParser [Char] -jClassType = do - x <- oneOf ['A' .. 'Z'] - xs <- many $ oneOf alphaNumUnderscore - return $ x:xs - -jBOp :: JackParser JBOp -jBOp = oneOf binaryOpChars - -jUOp :: JackParser JUOp -jUOp = oneOf unaryOpChars - -jComment :: JackParser () -jComment = jInlineComment <|> jBlockComment - -jInlineComment :: JackParser () -jInlineComment = return () <* - try (string "//" >> manyTill (noneOf "\n\r") endOfLine) - --try (string "//" >> manyTill (noneOf "\n") newline) - -jSpace :: JackParser () -jSpace = (return () <* space) <|> jComment - -jBlockComment :: JackParser () -jBlockComment = return () <* - try (string "/*" >> manyTill anyChar (try $ string "*/")) - -jPrimType :: JackParser JType -jPrimType = choice $ string <$> primTypeStrs - -jType :: JackParser JType -jType = choice [jPrimType, jClassType] - -jPrimType' :: JackParser JType -jPrimType' = choice $ string <$> primTypeStrs' - -jType' :: JackParser JType -jType' = choice [jPrimType', jClassType] - -jClassVarScope :: JackParser JClassVarScope -jClassVarScope = choice $ string <$> classVarScopeStrs - -jSubroutineType :: JackParser JSubroutineType -jSubroutineType = choice $ string <$> subroutineTypeStrs - -jIdentifier :: JackParser [Char] -jIdentifier = do - x <- oneOf alphaUnderscore - xs <- many $ oneOf alphaNumUnderscore - return $ x:xs - -jClassVarDecs :: JackParser [JClassVarDec] -jClassVarDecs = do - scope <- jClassVarScope - many1 jSpace - typeAndIds <- jTypeAndIds - many jSpace >> char ';' - return $ JClassVarDec scope <$> typeAndIds - -jVarDecs :: JackParser [JTypeAndId] -jVarDecs = - (string "var" >> many1 jSpace) >> jTypeAndIds <* (many jSpace >> char ';') - -jTypeAndId :: JackParser JType -> JackParser JTypeAndId -jTypeAndId p = do - type_ <- p - many1 jSpace - id <- jIdentifier - return (type_, id) - -jTypeAndIds :: JackParser [JTypeAndId] -jTypeAndIds = do - type_ <- jType - many1 jSpace - ids <- sepBy jIdentifier (try $ many jSpace >> char ',' >> many jSpace) - return $ (\x -> (type_, x)) <$> ids - -jParameters :: JackParser [JTypeAndId] -jParameters = do - char '(' >> many jSpace - params <- sepBy (jTypeAndId jType) (try $ many jSpace >> char ',' >> many jSpace) - many jSpace >> char ')' - return params - -jSubroutineHeader :: JackParser JSubroutineHeader -jSubroutineHeader = do - subtype <- jSubroutineType - many1 jSpace - typeAndId <- jTypeAndId jType' - params <- jParameters - return $ JSubroutineHeader subtype typeAndId params - -jExpression :: JackParser JExpression -jExpression = jExpBin <|> jTerm - -jTerm :: JackParser JExpression -jTerm = choice [jIntConst, jStrConst, jKeywordConst, jExpCall, jExpVar, jExpUna, jExpInBraces] - -jIntConst :: JackParser JExpression -jIntConst = JIntConst <$> (read <$> many1 digit) - -jStrConst :: JackParser JExpression -jStrConst = JStrConst <$> between (char '"') (char '"') (many $ noneOf "\"") - -jKeywordConst :: JackParser JExpression -jKeywordConst = JKeywordConst <$> (choice $ try <$> string <$> keywordConstStrs) - -jExpVar :: JackParser JExpression -jExpVar = JExpVar <$> jVarId - -jVarId :: JackParser JVarId -jVarId = do - id <- jIdentifier - maybeArray <- optionMaybe $ try (char '[' >> jExpression <* char ']') - return $ JVarId id maybeArray - -jExpCall :: JackParser JExpression -jExpCall = JExpCall <$> jSubroutineCall - -jExpUna :: JackParser JExpression -jExpUna = do - op <- oneOf unaryOpChars - many jSpace - x <- jTerm - return $ JExpUna op x - -jExpInBraces :: JackParser JExpression -jExpInBraces = between (char '(') (char ')') jExpression -- expressions like a + () is not allowed - -jExpBin :: JackParser JExpression -jExpBin = try $ do - x <- jTerm - xs <- many1 jOpAndTerm - return $ JExpBin x xs - -jOpAndTerm :: JackParser (JBOp, JExpression) -jOpAndTerm = do - op <- many jSpace >> jBOp - x <- many jSpace >> jTerm - return (op, x) - -jSubroutineDec :: JackParser JSubroutineDec -jSubroutineDec = do - header <- jSubroutineHeader - many jSpace - body <- jSubroutineBody - return $ JSubroutineDec header body - -jSubroutineBody :: JackParser JSubroutineBody -jSubroutineBody = do - char '{' - varDecs <- many $ try (many jSpace >> jVarDecs) - stmts <- many $ try (many jSpace >> jStatement) - many jSpace >> char '}' - return $ JSubroutineBody (mconcat varDecs) stmts - -jStatement :: JackParser JStatement -jStatement = choice [jLetStatement, jIfStatement, jWhileStatement, jDoStatement, jReturnStatement] - -jLetStatement :: JackParser JStatement -jLetStatement = do - string "let" >> many1 jSpace - leftVarId <- jVarId - many jSpace >> char '=' >> many jSpace - exp <- jExpression - many jSpace >> char ';' - return $ JLetStatment leftVarId exp - -jIfStatement = do - string "if" >> many jSpace >> char '(' >> many jSpace - exp <- jExpression - many jSpace >> char ')' >> many jSpace >> char '{' >> many jSpace - stmts <- many (try $ many jSpace >> jStatement) - many jSpace >> char '}' - stmts' <- optionMaybe $ try jElseBlock - return $ JIfStatement exp stmts stmts' - -jElseBlock :: JackParser [JStatement] -jElseBlock = do - many jSpace >> string "else" >> many jSpace >> char '{' >> many jSpace - stmts <- many (try $ many jSpace >> jStatement) - many jSpace >> char '}' - return stmts - -jWhileStatement :: JackParser JStatement -jWhileStatement = do - string "while" >> many jSpace >> char '(' >> many jSpace - exp <- jExpression - many jSpace >> char ')' >> many jSpace >> char '{' - stmts <- many (try $ many jSpace >> jStatement) - many jSpace >> char '}' - return $ JWhileStatment exp stmts - -jDoStatement :: JackParser JStatement -jDoStatement = do - jCall <- string "do" >> many jSpace >> jSubroutineCall - many jSpace >> char ';' - return $ JDoStatement jCall - -jReturnStatement :: JackParser JStatement -jReturnStatement = do - string "return" >> many jSpace - res <- optionMaybe $ try jExpression - many jSpace >> char ';' - return $ JReturnStatement res - -jSubroutineCall :: JackParser JSubroutineCall -jSubroutineCall = try $ do - callee <- jIdentifier - method <- optionMaybe $ try (char '.' >> jIdentifier) - args <- emptyArgs <|> someArgs - return $ JSubroutineCall callee method args - -emptyArgs :: JackParser [JExpression] -emptyArgs = return [] <* (try $ char '(' >> many jSpace >> char ')') - -someArgs :: JackParser [JExpression] -someArgs = do - char '(' >> many jSpace - exps <- sepBy jExpression (many jSpace >> char ',' >> many jSpace) - many jSpace >> char ')' - return exps - - --- vm writer starts from here - -buildCTable :: [JClassVarDec] -> (Table, Int) -buildCTable xs = go 0 0 Map.empty xs - where go n _ t [] = (t, n) - go nField nStatic t ((JClassVarDec "field" (ty, jId)):ys) = - go (nField + 1) nStatic (Map.insert jId (ty, ("this", nField)) t) ys - go nField nStatic t ((JClassVarDec "static" (ty, jId)):ys) = - go nField (nStatic + 1) (Map.insert jId (ty, ("static", nStatic)) t) ys - - ---data JClass = JClass JIdentifier [JClassVarDec] [JSubroutineDec] deriving (Show, Eq) -buildSRTable :: [JClass] -> Table -buildSRTable xs = Map.fromList $ mconcat $ go <$> xs where - go (JClass cName _ subs) = go' <$> subs where - go' (JSubroutineDec (JSubroutineHeader kind (ty, sName) args) _) = - (cName ++ "." ++ sName, (kind, (ty, nArgs))) where - nArgs = length args + if kind == "method" then 1 else 0 - -buildLTable :: Bool -> [JTypeAndId] -> [JTypeAndId] -> Table -buildLTable isMethod args lcls = - (go "argument" args (if isMethod then 1 else 0) Map.empty) `Map.union` (go "local" lcls 0 Map.empty) where - go _ [] _ t = t - go kind ((ty, name):xs) n t = go kind xs (n + 1) $ Map.insert name (ty, (kind, n)) t - ---data JSubroutineDec = JSubroutineDec JSubroutineHeader JSubroutineBody deriving (Show, Eq) ---data JSubroutineHeader = JSubroutineHeader JSubroutineType JTypeAndId [JTypeAndId] deriving (Show, Eq) ---data JSubroutineBody = JSubroutineBody [JTypeAndId] [JStatement] deriving (Show, Eq) - -jackCompiler :: Table -> [[Char]] -> [[Char]] -jackCompiler initTable = vmWriter initTable . fmap (fromRight (JClass "" [] []) . jackReader) - -vmWriter :: Table -> [JClass] -> [[Char]] -vmWriter initTable xs = vClass (buildSRTable xs `Map.union` initTable) <$> xs - -vClass :: Table -> JClass -> [Char] -vClass u (JClass name vars subs) = mconcat $ vSubroutineDec name t u n <$> subs where - (t, n) = buildCTable vars - -vSubroutineDec :: [Char] -> Table -> Table -> Int -> JSubroutineDec -> [Char] -vSubroutineDec cName t u n sub = - vFunction (cName ++ "." ++ sName) nLcls ++ kindSpec ++ - vStatement t s u cName sName 0 stmts where - JSubroutineDec (JSubroutineHeader _ (_, sName) args) (JSubroutineBody lcls stmts) = sub - nLcls = length lcls - kind = fst $ u Map.! (cName ++ "." ++ sName) - s = buildLTable (kind == "method") args lcls - kindSpec = if kind == "constructor" - then vNew n - else if kind == "method" - then vPush "argument" 0 ++ vPop "pointer" 0 - else "" - --- data JStatement = JLetStatment JVarId JExpression - -- | JIfStatement JExpression [JStatement] (Maybe [JStatement]) - -- | JWhileStatment JExpression [JStatement] - -- | JDoStatement JSubroutineCall - -- | JReturnStatement (Maybe JExpression) - -vStatement _ _ _ _ _ _ [] = "" - --- vExpression: push the result of exp; vPopToVar: pop to the var addr - -vStatement t s u cName name n ((JLetStatment var exp):stmts) = - vExpression t s u cName exp ++ vPopToVar t s u cName var ++ vStatement t s u cName name n stmts - -vStatement t s u cName name n ((JIfStatement cond thenStmts elseStmts):stmts) = - vExpression t s u cName cond ++ vNot ++ vThen thenStmts ++ - maybe (vLabel labelElse) vElse elseStmts ++ vStatement t s u cName name (n + 1) stmts where - labelElse = name ++ ".Else" ++ show n - labelEndIf = name ++ ".Endif" ++ show n - labelIf = name ++ ".If" ++ show n - vThen xs = vIfGoto labelElse ++ vStatement t s u cName labelElse 0 xs - vElse xs = vGoto labelEndIf ++ vLabel labelElse ++ - vStatement t s u cName labelIf 0 xs ++ vLabel labelEndIf - -vStatement t s u cName name n ((JWhileStatment cond loopStmts):stmts) = - vLabel labelWhile ++ vExpression t s u cName cond ++ vNot ++ vIfGoto labelEndWhile ++ - vStatement t s u cName labelWhile 0 loopStmts ++ vGoto labelWhile ++ - vLabel labelEndWhile ++ vStatement t s u cName name (n + 1) stmts where - labelWhile = name ++ ".While" ++ show n - labelEndWhile = name ++ ".EndWhile" ++ show n - -vStatement t s u cName name n ((JDoStatement subCall):stmts) = - vSubroutineCall t s u cName subCall ++ vPop "temp" 0 ++ vStatement t s u cName name n stmts - -vStatement t s u cName name n ((JReturnStatement ret):stmts) = - maybe (vPush "constant" 0) (vExpression t s u cName) ret ++ vReturn ++ - vStatement t s u cName name n stmts - --- data JExpression = JIntConst Int - -- | JStrConst [Char] - -- | JKeywordConst [Char] -- can only be true, false, null or this - -- | JExpVar JVarId - -- | JExpCall JSubroutineCall - -- | JExpUna JUOp JExpression -- JOp can only be - or ~ here - -- | JExpBin JExpression [(JBOp, JExpression)] - -vExpression :: Table -> Table -> Table -> [Char] -> JExpression -> [Char] - -vExpression t s _ _ (JIntConst n) = vPush "constant" n - -vExpression t s _ _ (JStrConst xs) = - vPush "constant" (length xs) ++ vCall "String.new" 1 ++ mconcat (go <$> xs) where - go x = vPush "constant" (ord x) ++ vCall "String.appendChar" 2 - -vExpression t s _ _ (JKeywordConst x) - | x == "null" || x == "false" = vPush "constant" 0 - | x == "true" = vPush "constant" 1 ++ vNeg - | x == "this" = vPush "pointer" 0 - -vExpression t s u cName (JExpVar (JVarId name idx)) = vVar t s u cName name idx vPush - -vExpression t s u cName (JExpCall subCall) = vSubroutineCall t s u cName subCall - -vExpression t s u cName (JExpUna op exp) = vExpression t s u cName exp ++ vOp op - where vOp '~' = vNot; vOp '-' = vNeg; - -vExpression t s u cName (JExpBin exp xs) = - vExpression t s u cName exp ++ mconcat (go <$> xs) - where go (op, exp) = vExpression t s u cName exp ++ vOp op - vOp '+' = vAdd; vOp '-' = vSub; vOp '*' = vMul; vOp '/' = vDiv; - vOp '&' = vAnd; vOp '|' = vOr; vOp '<' = vLt; vOp '>' = vGt; - vOp '=' = vEq; - -vPopToVar t s u cName (JVarId name idx) = vVar t s u cName name idx vPop - -vVar :: Table -> Table -> Table -> [Char] -> [Char] -> Maybe JExpression -> ([Char] -> Int -> [Char]) -> [Char] -vVar t s u cName name idx vPushOrPop = - let (seg, n) = getSegN t s name in - case idx of - Nothing -> vPushOrPop seg n - Just exp -> vPush seg n ++ vExpression t s u cName exp ++ vAdd - ++ vPop "pointer" 1 ++ vPushOrPop "that" 0 - - -getRecord :: Table -> Table -> [Char] -> ([Char], ([Char], Int)) -getRecord t s name = case Map.lookup name s of - Just x -> x - Nothing -> t Map.! name - -getSegN :: Table -> Table -> [Char] -> ([Char], Int) -getSegN t s name = snd $ getRecord t s name - -getType :: Table -> Table -> [Char] -> [Char] -getType t s name = fst $ getRecord t s name - --- data JSubroutineCall = JSubroutineCall JIdentifier (Maybe JIdentifier) [JExpression] deriving (Show, Eq) -vSubroutineCall t s u cName (JSubroutineCall name name' args) = - method ++ mconcat (vExpression t s u cName <$> args) ++ vCall name'' nArgs - where - name'' = if name' == Nothing - then cName ++ "." ++ name - else if head name `elem` ['A' .. 'Z'] - then name ++ "." ++ fromJust name' - else getType t s name ++ "." ++ fromJust name' - -- u is the SRTable - (method, nArgs) = - if fst (u Map.! name'') == "method" - then if name' == Nothing - then (vPush "pointer" 0, length args + 1) - else let (seg, n) = getSegN t s name in (vPush seg n, length args + 1) - else ("", length args) - -vNew n = vPush "constant" n ++ vCall "Memory.alloc" 1 ++ vPop "pointer" 0 -vAdd = "add\n" -vNot = "not\n" -vNeg = "neg\n" -vSub = "sub\n" -vMul = "call Math.multiply 2\n" -vDiv = "call Math.divide 2\n" -vAnd = "and\n" -vOr = "or\n" -vLt = "lt\n" -vGt = "gt\n" -vEq = "eq\n" -vReturn = "return\n" -vLabel xs = "label " ++ xs ++ "\n" -vGoto xs = "goto " ++ xs ++ "\n" -vIfGoto xs = "if-goto " ++ xs ++ "\n" -vFunction xs n = "function " ++ xs ++ " " ++ show n ++ "\n" -vCall xs n = "call " ++ xs ++ " " ++ show n ++ "\n" -vPush xs n = "push " ++ xs ++ " " ++ show n ++ "\n" -vPop xs n = "pop " ++ xs ++ " " ++ show n ++ "\n" - - --- IO - --- reader of system subroutines' headers -jClasses :: JackParser [JClass] -jClasses = many (try $ many jSpace >> jClass) - -sysSubroutineTable :: IO Table -sysSubroutineTable = do - x <- readFile "./systemsub.txt" - return $ buildSRTable $ head $ rights [parse' jClasses x] - -main = do - dir <- head <$> getArgs - filesWODir <- filter isJackFile <$> listDirectory dir - let jackFiles = (dir++) <$> filesWODir - codes <- sequence $ readFile <$> jackFiles - initTable <- sysSubroutineTable - zipWithM writeFile (chExt <$> jackFiles) (jackCompiler initTable codes) - where isJackFile xs = drop (length xs - 5) xs == ".jack" - chExt xs = take (length xs - 4) xs ++ "vm" - --} - - ---testing - -testCompiler :: [[Char]] -> IO () -testCompiler xs = do - initTable <- sysSubroutineTable - print $ jackCompiler initTable xs - -testCompiler' :: IO () -testCompiler' = do - --xs <- readFile "./Square/Square.jack" - xs <- readFile "./Pong/Ball.jack" - testCompiler [xs] - -testReader :: IO () -testReader = do - --xs <- readFile "./Square/Square.jack" - xs <- readFile "./Pong/Ball.jack" - --print $ buildSRTable $ rights $ [jackReader $ xs] - print $ jackReader $ xs - - ---test reader writer x = let Right y = parse' reader x in writer y ---test' x = let Right y = parse' jStatement x in vStatement Map.empty Map.empty Map.empty "" 0 [y] - - |