2 changed files with 287 additions and 18 deletions
@ -1,37 +1,301 @@
@@ -1,37 +1,301 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
{-# LANGUAGE MultiWayIf #-} |
||||
|
||||
module Main where |
||||
|
||||
import Data.Binary |
||||
import qualified Data.Map.Strict as M |
||||
import qualified Data.Text as T |
||||
import qualified Data.Text.IO as TIO |
||||
import qualified Data.ByteString.Lazy as BL |
||||
import Text.Megaparsec (Parsec, runParserT, many, skipManyTill, runParser, some, errorBundlePretty, ShowErrorComponent, skipMany, notFollowedBy, MonadParsec (eof, lookAhead), choice, try, oneOf) |
||||
import qualified Options.Applicative as O |
||||
import Options.Applicative (fullDesc, info, (<**>), helper, progDesc, header, strOption, long, metavar, help, execParser, short) |
||||
import Control.Applicative hiding (many, some) |
||||
import Text.Megaparsec.Char (char, space, eol, alphaNumChar, letterChar, string, printChar, spaceChar, space1, string') |
||||
import Text.Megaparsec.Error (ShowErrorComponent(showErrorComponent)) |
||||
import Text.Megaparsec.Debug |
||||
import Control.Monad (void, when, forM, forM_) |
||||
import Text.Megaparsec.Char.Lexer (decimal, skipLineComment, symbol) |
||||
import qualified Text.Megaparsec.Char.Lexer as L |
||||
import Data.Maybe (catMaybes, fromMaybe) |
||||
import Text.Megaparsec.Byte.Lexer (symbol') |
||||
import Data.Foldable (Foldable(foldl')) |
||||
import Data.Word (Word16) |
||||
import Data.Bits ((.|.), Bits (shift, testBit)) |
||||
import Debug.Trace |
||||
import GHC.IO.IOMode (IOMode(WriteMode)) |
||||
import System.IO (withFile, hPutStrLn) |
||||
|
||||
|
||||
data HackInstruction = |
||||
A Imm |
||||
| C [Dest] Source Jump |
||||
| C [Reg] Source Jump |
||||
deriving (Eq, Show) |
||||
|
||||
data Imm = Imm Int | Label T.Text |
||||
deriving (Show, Eq) |
||||
|
||||
data Dest = DestA | DestM | DestD |
||||
data Reg = RegA | RegM | RegD |
||||
deriving (Eq, Show) |
||||
|
||||
data Source = |
||||
S0 |
||||
| S1 |
||||
| SNeg1 |
||||
| SD |
||||
| SA |
||||
| SM |
||||
| SNotD |
||||
| SNotA |
||||
| SNotM |
||||
| SNegD |
||||
| SNegA |
||||
| SNegM |
||||
| SDPlus1 |
||||
| SAPlus1 |
||||
| SMPlus1 |
||||
| SDMinus1 |
||||
| SAMinus1 |
||||
| SMMinus1 |
||||
| SReg Reg |
||||
| SNot Reg |
||||
| SNeg Reg |
||||
| SRegPlus1 Reg |
||||
| SRegMinus1 Reg |
||||
| SDPlusA |
||||
| SDPlusM |
||||
| SDMinusA |
||||
| SDMinusM |
||||
| SAMinusD |
||||
| SMMinusD |
||||
| SDAndA |
||||
| SDAndM |
||||
| SDOrA |
||||
| SDOrM |
||||
deriving (Show, Eq) |
||||
|
||||
data Jump = |
||||
JNone |
||||
| JGt |
||||
| JEq |
||||
| JGe |
||||
| JLt |
||||
| JNe |
||||
| JLe |
||||
| Jmp |
||||
deriving (Show, Eq) |
||||
|
||||
data Error = ParsingError T.Text Int |
||||
deriving (Show, Eq, Ord) |
||||
|
||||
instance ShowErrorComponent Error where |
||||
showErrorComponent = show |
||||
|
||||
type Parser = Parsec Error T.Text |
||||
|
||||
data AsmLine = |
||||
LineInstruction HackInstruction |
||||
| LineLabel T.Text |
||||
deriving (Show, Eq) |
||||
|
||||
data Options = |
||||
Options |
||||
{ |
||||
inputFile :: FilePath, |
||||
outputFile :: FilePath |
||||
} |
||||
|
||||
hackParser :: Parser [AsmLine] |
||||
hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof |
||||
where |
||||
parseInstruction :: Parser AsmLine |
||||
parseInstruction = try (aInstr <|> cInstr) |
||||
|
||||
aInstr :: Parser AsmLine |
||||
aInstr = do |
||||
char '@' |
||||
space |
||||
aInstrOffset <|> aInstrLabel |
||||
|
||||
aInstrOffset :: Parser AsmLine |
||||
aInstrOffset = LineInstruction . A . Imm <$> decimal |
||||
|
||||
aInstrLabel :: Parser AsmLine |
||||
aInstrLabel = LineInstruction . A . Label <$> idParser |
||||
|
||||
cInstr = do |
||||
target <- optional $ try (many parseReg <* (space >> char '=' >> space)) |
||||
comp <- parseComputation |
||||
jump <- optional parseJump |
||||
|
||||
return . LineInstruction $ C (fromMaybe [] target) comp (fromMaybe JNone jump) |
||||
|
||||
parseReg :: Parser Reg |
||||
parseReg = try (char 'A' *> pure RegA) <|> try (char 'D' *> pure RegD) <|> try (char 'M' *> pure RegM) |
||||
|
||||
parseComputation :: Parser Source |
||||
parseComputation = space >> |
||||
(try $ char '0' *> pure S0) <|> |
||||
(try $ char '1' *> pure S1) <|> |
||||
(try $ string "-1" *> pure SNeg1) <|> |
||||
(try $ char '!' *> space *> parseReg >>= pure . SNot) <|> |
||||
(try $ char '-' *> space *> parseReg >>= pure . SNeg) <|> |
||||
(try $ parseReg <* space <* char '+' <* space <* char '1' >>= pure . SRegPlus1) <|> |
||||
(try $ parseReg <* space <* char '-' <* space <* char '1' >>= pure . SRegMinus1) <|> |
||||
(try parseBinop) <|> |
||||
(try $ parseReg >>= pure . SReg) |
||||
|
||||
parseBinop :: Parser Source |
||||
parseBinop = do |
||||
space |
||||
r1 <- parseReg |
||||
space |
||||
op <- oneOf ['+', '-', '&', '|'] |
||||
space |
||||
r2 <- parseReg |
||||
when (r1 == r2) $ fail "Same register is not allowed in binary operation" |
||||
when (r1 /= RegD && r2 /= RegD) $ fail "One of operands of binary operation should be D" |
||||
if |
||||
| op == '+' -> |
||||
return $ if r1 == RegA || r2 == RegA then SDPlusA else SDPlusM |
||||
| op == '&' -> |
||||
return $ if r1 == RegA || r2 == RegA then SDAndA else SDAndM |
||||
| op == '|' -> |
||||
return $ if r1 == RegA || r2 == RegA then SDOrM else SDOrM |
||||
| op == '-' && r1 == RegD -> return $ if r2 == RegA then SDMinusA else SDMinusM |
||||
| op == '-' && r1 == RegA -> return SAMinusD |
||||
| op == '-' && r1 == RegM -> return SMMinusD |
||||
|
||||
parseJump :: Parser Jump |
||||
parseJump = try $ do |
||||
space |
||||
char ';' |
||||
space |
||||
(try $ string' "jgt" *> pure JGt) <|> |
||||
(try $ string' "jeq" *> pure JEq) <|> |
||||
(try $ string' "jge" *> pure JGe) <|> |
||||
(try $ string' "jlt" *> pure JLt) <|> |
||||
(try $ string' "jne" *> pure JNe) <|> |
||||
(try $ string' "jle" *> pure JLe) <|> |
||||
(try $ string' "jmp" *> pure Jmp) |
||||
|
||||
parseLabel :: Parser AsmLine |
||||
parseLabel = try $ do |
||||
char '(' |
||||
labelId <- idParser |
||||
char ')' |
||||
return $ LineLabel labelId |
||||
|
||||
idParser :: Parser T.Text |
||||
idParser = T.pack <$> some (letterChar <|> oneOf ['.', '_', '$']) <> many alphaNumChar |
||||
|
||||
notEol :: Parser Char |
||||
notEol = skipManyTill (notFollowedBy eol) spaceChar |
||||
|
||||
sp :: Parser () |
||||
sp = L.space space1 (skipLineComment "//") empty |
||||
|
||||
type LabelMap = M.Map T.Text Int |
||||
|
||||
addLabel :: (Int, LabelMap) -> AsmLine -> (Int, LabelMap) |
||||
addLabel (i, m) (LineInstruction _) = (i + 1, m) |
||||
addLabel (i, m) (LineLabel v) = (i, M.insert v i m) |
||||
|
||||
addVars :: LabelMap -> (Int, LabelMap) -> AsmLine -> (Int, LabelMap) |
||||
addVars labs (cnt, m) (LineInstruction (A (Label v))) = case M.lookup v labs of |
||||
Just _ -> (cnt, m) |
||||
Nothing -> case M.lookup v m of |
||||
Just _-> (cnt, m) |
||||
Nothing -> (cnt + 1, M.insert v cnt m) |
||||
addVars _ m _ = m |
||||
|
||||
compile :: LabelMap -> LabelMap -> [HackInstruction] -> Either T.Text [Word16] |
||||
compile labels vars lines = forM lines compileInstruction |
||||
where |
||||
compileInstruction (A (Imm i)) = |
||||
if i > 32767 || i < -32768 |
||||
then Left "Invalid immediate value" |
||||
else Right $ fromIntegral i |
||||
compileInstruction (A (Label l)) = |
||||
case M.lookup l labels of |
||||
Just offset -> Right $ fromIntegral offset |
||||
Nothing -> case M.lookup l vars of |
||||
Just offset -> Right $ fromIntegral offset |
||||
Nothing -> Left $ "Invalid label: " <> l |
||||
compileInstruction (C dest src jmp) = Right $ |
||||
0xe000 .|. compileSourceOperand src .|. compileDestOperand dest .|. compileJump jmp |
||||
|
||||
compileSourceOperand :: Source -> Word16 |
||||
compileSourceOperand src = compileSourceOperand' src `shift` 6 |
||||
|
||||
compileSourceOperand' S0 = 0x2a |
||||
compileSourceOperand' S1 = 0x3f |
||||
compileSourceOperand' SNeg1 = 0x3a |
||||
compileSourceOperand' (SReg RegA) = 0x30 |
||||
compileSourceOperand' (SReg RegM) = 0x70 |
||||
compileSourceOperand' (SReg RegD) = 0x0c |
||||
compileSourceOperand' (SNot RegA) = 0x31 |
||||
compileSourceOperand' (SNot RegM) = 0x71 |
||||
compileSourceOperand' (SNot RegD) = 0x0d |
||||
compileSourceOperand' (SNeg RegA) = 0x33 |
||||
compileSourceOperand' (SNeg RegM) = 0x73 |
||||
compileSourceOperand' (SNeg RegD) = 0x0f |
||||
compileSourceOperand' (SRegPlus1 RegA) = 0x37 |
||||
compileSourceOperand' (SRegPlus1 RegM) = 0x77 |
||||
compileSourceOperand' (SRegPlus1 RegD) = 0x1f |
||||
compileSourceOperand' (SRegMinus1 RegA) = 0x32 |
||||
compileSourceOperand' (SRegMinus1 RegM) = 0x72 |
||||
compileSourceOperand' (SRegMinus1 RegD) = 0x0e |
||||
compileSourceOperand' SDPlusA = 0x02 |
||||
compileSourceOperand' SDPlusM = 0x42 |
||||
compileSourceOperand' SDMinusA = 0x13 |
||||
compileSourceOperand' SDMinusM = 0x53 |
||||
compileSourceOperand' SAMinusD = 0x07 |
||||
compileSourceOperand' SMMinusD = 0x47 |
||||
compileSourceOperand' SDAndA = 0x00 |
||||
compileSourceOperand' SDAndM = 0x40 |
||||
compileSourceOperand' SDOrA = 0x15 |
||||
compileSourceOperand' SDOrM = 0x55 |
||||
|
||||
compileDestOperand dests = compileDestOperand' dests `shift` 3 |
||||
compileDestOperand' :: [Reg] -> Word16 |
||||
compileDestOperand' = foldl' compileDestBit (0 :: Word16) |
||||
|
||||
compileDestBit :: Word16 -> Reg -> Word16 |
||||
compileDestBit b RegA = b .|. 4 |
||||
compileDestBit b RegM = b .|. 1 |
||||
compileDestBit b RegD = b .|. 2 |
||||
|
||||
compileJump JNone = 0 |
||||
compileJump JGt = 1 |
||||
compileJump JEq = 2 |
||||
compileJump JGe = 3 |
||||
compileJump JLt = 4 |
||||
compileJump JNe = 5 |
||||
compileJump JLe = 6 |
||||
compileJump Jmp = 7 |
||||
|
||||
|
||||
main :: IO () |
||||
main = do |
||||
putStrLn "hello world" |
||||
options <- execParser opts |
||||
programText <- TIO.readFile (inputFile options) |
||||
let result = runParser hackParser (inputFile options) programText |
||||
case result of |
||||
Left err -> putStrLn $ errorBundlePretty err |
||||
Right parsed -> do |
||||
let labels = snd $ foldl' addLabel (0, M.empty) parsed |
||||
let vars = snd $ foldl' (addVars labels) (16, regVars) parsed |
||||
print vars |
||||
let compiled = compile labels vars $ foldr addInstr [] parsed |
||||
case compiled of |
||||
Left err -> putStrLn $ "Error: " <> T.unpack err |
||||
Right program -> withFile (outputFile options) WriteMode $ \h -> forM_ program (\x -> hPutStrLn h (printInstruction x)) |
||||
where |
||||
printInstruction w = concatMap (\x -> if testBit w x then "1" else "0") $ reverse [0..15] |
||||
regVars = M.fromList $ [("SP", 0), ("LCL", 1), ("ARG", 2), ("THIS", 3), ("THAT", 4)] <> |
||||
zip (fmap (\x -> "R" <> (T.pack . show $ x)) [0..15 :: Int]) [0..15 :: Int] |
||||
addInstr (LineInstruction instr) is = instr : is |
||||
addInstr _ is = is |
||||
|
||||
opts = info (hackAsmOptParser <**> helper) |
||||
( fullDesc |
||||
<> progDesc "Compiles a file with Hack assembly instructions to Hask binary code" |
||||
<> header "hackasm - assembler for hack CPU (nand2tetris)" ) |
||||
hackAsmOptParser = Options <$> |
||||
strOption ( long "input" |
||||
<> short 'i' |
||||
<> metavar "FILENAME" |
||||
<> help "Input file" ) <*> |
||||
strOption ( long "output" |
||||
<> short 'o' |
||||
<> metavar "FILENAME" |
||||
<> help "Output file" ) |
||||
|
||||
|
||||
|
||||
Loading…
Reference in new issue