[WIP] initial compiler backend code

compiler/.gitignore

@@ -0,0 +1 @@
+_build

compiler/.ocamlformat

@@ -0,0 +1,2 @@
+profile = janestreet
+version = 0.24.1

compiler/README.md

@@ -0,0 +1 @@
+

compiler/bin/compiler.ml

@@ -0,0 +1,31 @@
+open Core
+open Backend
+
+let read_file file =
+  let not_empty str = not (String.is_empty str) in
+  List.filter (In_channel.read_lines file) ~f:not_empty
+;;
+
+let outfile file = String.concat [ Filename.chop_extension file; ".asm" ]
+
+let gen_hack file =
+  let ircode = read_file file in
+  let assembly = Be_translate.translate ircode in
+  let outchan = Out_channel.create (outfile file) in
+  Out_channel.output_lines outchan assembly;
+  Out_channel.close outchan
+;;
+
+let param =
+  let open Command.Param in
+  anon ("filename" %: string)
+;;
+
+let command =
+  Command.basic
+    ~summary:"Translate <filename>.vm to <filename>.asm"
+    ~readme:(fun () -> "Compiler (backend) for project 7 of Nand2Tetris")
+    (Command.Param.map param ~f:(fun filename () -> gen_hack filename))
+;;
+
+let () = Command_unix.run command

compiler/bin/dune

@@ -0,0 +1,3 @@
+(executable
+ (name compiler)
+ (libraries backend core core_unix.command_unix))

compiler/dune-project

@@ -0,0 +1,2 @@
+(lang dune 3.3)
+(using menhir 2.0)

compiler/lib/be_ast.ml

@@ -0,0 +1,4 @@
+type expr =
+  | Comment of string
+  | Acommand of string
+  | Mcommand of string * string * string

compiler/lib/be_lexer.mll

@@ -0,0 +1,57 @@
+{
+open Be_parser
+}
+
+let address   = ['0'-'9']+
+
+(* let ADD       = "add"
+let SUB       = "sub"
+let NEG       = "neg"
+let EQ        = "eq"
+let GT        = "gt"
+let LT        = "lt"
+let AND       = "and"
+let OR        = "or"
+let NOT       = "not"
+let POP       = "pop"
+let PUSH      = "push" *)
+
+let command   = "add"
+              | "sub"
+              | "neg"
+              | "eq"
+              | "gt"
+              | "lt"
+              | "and"
+              | "or"
+              | "not"
+              | "pop"
+              | "push"
+
+let segment   = "argument"
+              | "local"
+              | "static"
+              | "this"
+              | "that"
+              | "pointer"
+              | "temp"
+              | "constant"
+
+let white     = [' ' '\t']+
+let comment   = "//" _*
+
+(* 
+let digit      = ['0'-'9']
+let letter     = ['a'-'z' 'A'-'Z']
+let special    = ['.' '$' '_' '-' '+' '&' '!' '|']
+let id         = (digit | letter | special)+ 
+*)
+
+rule read =
+  parse
+  | white          { read lexbuf }
+  | address as a   { ADDRESS (a) }
+  | command as c   { COMMAND (c) }
+  | segment as s   { SEGMENT (s) }
+  | comment as c   { COMMENT (c) }
+  | eof            { EOF }

compiler/lib/be_parser.mly

@@ -0,0 +1,24 @@
+%{
+open Be_ast
+%}
+
+%token <string> ADDRESS
+%token <string> COMMAND
+%token <string> SEGMENT 
+%token <string> COMMENT
+%token EOF
+
+%start <Be_ast.expr> prog
+
+%%
+
+prog:
+  | e = expr; EOF { e }
+  ;
+
+expr:
+  | c = COMMENT                              { Comment c }
+  | c = COMMAND;                             { Acommand c }
+  | c = COMMAND; s = SEGMENT; a = ADDRESS    { Mcommand (c, s, a) }
+  | e = expr; COMMENT                        { e }
+  ;

compiler/lib/be_predef.ml

@@ -0,0 +1,81 @@
+open Base
+
+let _unary = [ "@SP"; "A=M-1" ]
+let _binary = [ "@SP"; "AM=M-1"; "D=M"; "A=A-1" ]
+let _add = _binary @ [ "M=M+D" ]
+let _sub = _binary @ [ "M=M-D" ]
+let _neg = _unary @ [ "M=-M" ]
+let _and = _binary @ [ "M=D&M" ]
+let _or = _binary @ [ "M=D|M" ]
+let _not = _unary @ [ "M=!M" ]
+
+let _eq loc =
+  _binary
+  @ [ "D=M-D"
+    ; "M=-1"
+    ; "@END_EQ_" ^ loc
+    ; "D;JEQ"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_EQ_" ^ loc ^ ")"
+    ]
+;;
+
+let _gt loc =
+  _binary
+  @ [ "D=M-D"
+    ; "M=-1"
+    ; "@END_GT_" ^ loc
+    ; "D;JGT"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_GT_" ^ loc ^ ")"
+    ]
+;;
+
+let _lt loc =
+  _binary
+  @ [ "D=M-D"
+    ; "M=-1"
+    ; "@END_LT_" ^ loc
+    ; "D;JLT"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_LT_" ^ loc ^ ")"
+    ]
+;;
+
+let a_command ?(loc = 0) a =
+  let suffix = Int.to_string loc in
+  match a with
+  | "add" -> _add
+  | "sub" -> _sub
+  | "neg" -> _neg
+  | "eq" -> _eq suffix
+  | "gt" -> _gt suffix
+  | "lt" -> _lt suffix
+  | "and" -> _and
+  | "or" -> _or
+  | "not" -> _not
+  | _ -> failwith "a_command: Invalid Command"
+;;
+
+let addr a = [ String.concat [ "@"; a ] ]
+let push_constant = [ "D=A"; "@SP"; "A=M"; "M=D"; "@SP"; "M=M+1" ]
+
+let _end = ["(TERMINATE)"; "@TERMINATE"; "0;JMP"]
+
+let _process_push s a =
+  match s with
+  | "constant" -> addr a @ push_constant
+  | _ -> failwith "Invalid Segment"
+;;
+
+let m_command (c, s, a) =
+  match c with
+  | "push" -> _process_push s a
+  | _ -> failwith "m_command: Invalid Command"
+;;

compiler/lib/be_translate.ml

@@ -0,0 +1,24 @@
+open Base
+open Be_ast
+open Be_predef
+
+let parse s =
+  let lexbuf = Lexing.from_string s in
+  let ast = Be_parser.prog Be_lexer.read lexbuf in
+  ast
+;;
+
+let generate_exprs lines = List.map lines ~f:parse
+
+let rec _translate expr loc tt = 
+  match expr with
+  | [] -> tt
+  | Acommand a :: t -> a_command ?loc:(Some loc) a @ _translate t (loc+1) tt
+  | Mcommand (c, s, a) :: t -> m_command (c, s, a) @ _translate t loc tt
+  | _ :: t -> _translate t loc tt
+;;
+
+let translate lines =
+  let exprs = generate_exprs lines in
+  _translate exprs 0 [] @ _end
+;;

compiler/lib/dune

@@ -0,0 +1,9 @@
+(ocamllex be_lexer)
+
+(menhir
+ (modules be_parser))
+
+(library
+ (name backend)
+ (modules be_ast be_predef be_translate be_lexer be_parser)
+ (libraries base))

compiler/test/dune

@@ -0,0 +1,3 @@
+(tests
+ (names test_backend)
+ (libraries backend ounit2))

compiler/test/test_backend.ml

@@ -0,0 +1,31 @@
+open OUnit2
+open Backend.Be_ast
+open Backend.Be_translate
+
+let peq case value = assert_equal value (parse case)
+
+let test_parse_a_command _ =
+  peq "add" (Acommand "add");
+  peq "sub" (Acommand "sub");
+  peq "neg" (Acommand "neg");
+  peq "eq" (Acommand "eq");
+  peq "gt" (Acommand "gt");
+  peq "lt" (Acommand "lt");
+  peq "and" (Acommand "and");
+  peq "or" (Acommand "or");
+  peq "not" (Acommand "not")
+;;
+
+let test_parse_m_command _ =
+  peq "pop local 12" (Mcommand ("pop", "local", "12"));
+  peq "push argument 4" (Mcommand ("push", "argument", "4"))
+;;
+
+let suite =
+  "suite"
+  >::: [ "A Instruction" >:: test_parse_a_command
+       ; "M Instruction" >:: test_parse_m_command
+       ]
+;;
+
+let () = run_test_tt_main suite