finish project eight backend compiler

- modify existing implementation to use variant types for a more
  accurate representation of the vm byte code
- switch to fold from recursion for the main translate function
- use separate modules for translating different vm commands
- move static arithmetic command translations to a map

compiler/backend/.gitignore

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

compiler/backend/.ocamlformat

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

compiler/backend/README.md

@@ -0,0 +1 @@
+

compiler/backend/bin/compiler.ml

@@ -0,0 +1,61 @@
+open Core
+open Backend
+
+let read_file file =
+  let lines = In_channel.read_lines file in
+  let not_empty str = not (String.is_empty str) in
+  List.filter lines ~f:not_empty
+
+
+let is_vm_file f =
+  match Filename.split_extension f with
+  | _, Some ext -> String.equal ext "vm"
+  | _, None -> false
+
+
+let generate_hack f =
+  let bytecode = read_file f in
+  let class_name = Filename.basename f in
+  Translate.translate class_name bytecode
+
+
+let write_hack path hack =
+  let output_channel = Out_channel.create path in
+  Out_channel.output_lines output_channel hack;
+  Out_channel.close output_channel
+
+
+let compile path =
+  let ext = ".asm" in
+  let absolute_path x = path ^ x in
+  let open Filename_base in
+    if Sys_unix.is_directory_exn path then
+      let output_file = concat path (basename path ^ ext) in
+      let hack =
+        path
+        |> Sys_unix.ls_dir
+        |> List.map ~f:absolute_path
+        |> List.filter ~f:is_vm_file
+        |> List.concat_map ~f:generate_hack
+        |> List.append Translate.bootstrap
+      in
+      write_hack output_file hack
+    else if Sys_unix.is_file_exn path && is_vm_file path then
+      let output_file = chop_extension path ^ ext in
+      let hack = generate_hack path in
+      write_hack output_file hack
+    else
+      failwith "Incompatible!"
+
+
+let command =
+  let summary = "Translate Jack byte code to Hack assembly" in
+  let readme () = "Compiler (backend) for project 7/8 of Nand2Tetris" in
+  let param_spec = Command.Param.(anon ("path" %: string)) in
+  let param_handler path () = compile path in
+  Command.basic
+    ~summary:summary ~readme:readme
+    (Command.Param.map param_spec ~f:param_handler)
+
+
+let () = Command_unix.run command

compiler/backend/bin/compiler.mli

@@ -0,0 +1 @@
+val command : Command.t

compiler/backend/bin/dune

@@ -0,0 +1,5 @@
+(executable
+ (modes byte exe)
+ (name compiler)
+ (public_name compiler)
+ (libraries backend core core_unix.command_unix))

compiler/backend/dune-project

@@ -0,0 +1,2 @@
+(lang dune 3.13)
+(using menhir 3.0)

compiler/backend/lib/arithmetic.ml

@@ -0,0 +1,78 @@
+open! Ast
+open! Base
+
+let counter = ref 0
+
+let count =
+  fun () ->
+    counter := (!counter) + 1;
+    !counter
+
+
+let arithmetic =
+  Map.of_alist_exn (module String)
+    [ "add", [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=D+M" ]
+    ; "sub", [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=M-D" ]
+    ; "and", [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=D&M" ]
+    ; "or" , [ "@SP"; "AM=M-1"; "D=M"; "A=A-1"; "M=D|M" ]
+    ; "neg", [ "@SP"; "A=M-1"; "M=-M" ]
+    ; "not", [ "@SP"; "A=M-1"; "M=!M" ]
+    ]
+
+let eq count =
+  [ "@SP"
+    ; "AM=M-1"
+    ; "D=M"
+    ; "A=A-1"
+    ; "D=M-D"
+    ; "M=-1"
+    ; "@END_EQ_" ^ count
+    ; "D;JEQ"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_EQ_" ^ count ^ ")"
+  ]
+
+let gt count =
+  [ "@SP"
+    ; "AM=M-1"
+    ; "D=M"
+    ; "A=A-1"
+    ; "D=M-D"
+    ; "M=-1"
+    ; "@END_GT_" ^ count
+    ; "D;JGT"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_GT_" ^ count ^ ")"
+  ]
+
+let lt count =
+  [ "@SP"
+    ; "AM=M-1"
+    ; "D=M"
+    ; "A=A-1"
+    ; "D=M-D"
+    ; "M=-1"
+    ; "@END_LT_" ^ count
+    ; "D;JLT"
+    ; "@SP"
+    ; "A=M-1"
+    ; "M=0"
+    ; "(END_LT_" ^ count ^ ")"
+  ]
+
+let translate command =
+  let i = Int.to_string (count ()) in
+  match command with
+  | Add -> Map.find_exn arithmetic "add"
+  | Sub -> Map.find_exn arithmetic "sub"
+  | Neg -> Map.find_exn arithmetic "neg"
+  | And -> Map.find_exn arithmetic "and"
+  | Not -> Map.find_exn arithmetic "not"
+  | Or  -> Map.find_exn arithmetic "or"
+  | Eq  -> eq i
+  | Gt  -> gt i
+  | Lt  -> lt i

compiler/backend/lib/arithmetic.mli

@@ -0,0 +1 @@
+val translate : Ast.arithmetic_command -> string list

compiler/backend/lib/ast.ml

@@ -0,0 +1,41 @@
+type arithmetic_command =
+  | Add
+  | Sub
+  | Neg
+  | Eq
+  | Gt
+  | Lt
+  | And
+  | Or
+  | Not
+
+type memory_segment =
+  | Argument
+  | Local
+  | Static
+  | Constant
+  | This
+  | That
+  | Pointer
+  | Temp
+
+type memory_command =
+  | Push
+  | Pop
+
+type branching_command =
+  | Label
+  | Goto
+  | Ifgoto
+
+type function_command =
+  | Function
+  | Call
+
+type expr =
+  | Comment of string
+  | ArithmeticCommand of arithmetic_command
+  | MemoryAccessCommand of memory_command * memory_segment * int
+  | ProgramFlowCommand of branching_command * string
+  | FunctionCallCommand of function_command * string * int
+  | Return

compiler/backend/lib/dune

@@ -0,0 +1,8 @@
+(ocamllex lexer)
+
+(menhir
+ (modules parser))
+
+(library
+ (name backend)
+ (libraries core))

compiler/backend/lib/functioncall.ml

@@ -0,0 +1,95 @@
+open! Ast
+open! Base
+
+let counter = ref 0
+
+let count =
+  fun () ->
+    counter := (!counter) + 1;
+    !counter
+
+let addr a = "@" ^ a
+
+let label name = "(" ^ name ^ ")"      
+
+let function_definition name arg =
+  let push_inner n = [
+    addr n
+    ; "D=A"
+    ; "@LCL"
+    ; "A=D+M"
+    ; "M=0"
+    ; "@SP"
+    ; "M=M+1"
+    ] in
+  let locals = arg
+    |> List.init ~f:Int.to_string
+    |> List.concat_map ~f:push_inner in
+  List.append [ label name ] locals
+
+let function_call name arg =
+  let i = Int.to_string (count ()) in
+  let arg = Int.to_string arg in
+  let ret = name ^ "_RETURN_" ^ i in
+  [ addr ret
+  ; "D=A"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push LCL "
+  ; "@LCL"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push ARG "
+  ; "@ARG"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push THIS "
+  ; "@THIS"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// push THAT "
+  ; "@THAT"
+  ; "D=M"
+  ; "@SP"
+  ; "A=M"
+  ; "M=D"
+  ; "@SP"
+  ; "M=M+1"
+  ; "// reposition ARG"
+  ; "D=M"
+  ; addr arg
+  ; "D=D-A"
+  ; "@5"
+  ; "D=D-A"
+  ; "@ARG"
+  ; "M=D"
+  ; "// reposition LCL"
+  ; "@SP"
+  ; "D=M"
+  ; "@LCL"
+  ; "M=D"
+  ; "// goto function"
+  ; addr name
+  ; "0;JMP"
+  ; label ret ]
+
+let translate command name arg =
+  match command with
+  | Function -> function_definition name arg
+  | Call -> function_call name arg
+  

compiler/backend/lib/functioncall.mli

@@ -0,0 +1 @@
+val translate : Ast.function_command -> string -> int -> string list

compiler/backend/lib/lexer.mll

@@ -0,0 +1,49 @@
+{
+open Parser
+}
+
+let period     = '.'
+let colon      = ':'
+let underscore = '_'
+let numbers    = ['0'-'9']+
+let alphabets  = ['a'-'z' 'A'-'Z']+
+let white      = [' ' '\t']+
+let comment    = "//" _*
+
+
+let address    = (numbers)+
+let id         = (alphabets | numbers | colon | period | underscore)+
+
+rule read =
+  parse
+  | white          { read lexbuf }
+  | comment as c   { COMMENT (c) }
+  | "add"          { ADD } 
+  | "sub"          { SUB }
+  | "neg"          { NEG }
+  | "eq"           { EQ }
+  | "gt"           { GT }
+  | "lt"           { LT }
+  | "and"          { AND }
+  | "or"           { OR }
+  | "not"          { NOT }
+  | "pop"          { POP }
+  | "push"         { PUSH }  
+  | "argument"     { ARGUMENT }  
+  | "local"        { LOCAL }  
+  | "static"       { STATIC }  
+  | "this"         { THIS }  
+  | "that"         { THAT }  
+  | "pointer"      { POINTER }  
+  | "temp"         { TEMP }  
+  | "constant"     { CONSTANT }  
+  | "label"        { LABEL }
+  | "goto"         { GOTO }
+  | "if-goto"      { IFGOTO }
+  | "function"     { FUNCTION }
+  | "call"         { CALL }
+  | "return"       { RETURN }
+  | address as a   { ADDRESS (int_of_string a) }
+  | id as i        { ID (i) }
+  | eof            { EOF }
+  | _ as c         { failwith (Printf.sprintf "unexpected character: %C" c) }

compiler/backend/lib/memoryaccess.ml

@@ -0,0 +1,68 @@
+open! Ast
+open! Base
+
+let addr a = "@" ^ a
+
+let push = [ "@SP"; "A=M"; "M=D"; "@SP"; "M=M+1" ]
+let pop = [ "@R13"; "M=D"; "@SP"; "AM=M-1"; "D=M"; "@R13"; "A=M"; "M=D" ]
+
+let common = function
+  | Local -> "@LCL"
+  | This -> "@THIS"
+  | That -> "@THAT"
+  | Argument -> "@ARG"
+  | _ -> failwith "Invalid Segment"
+
+let pointer = function
+  | "0" -> "@THIS"
+  | "1" -> "@THAT"
+  | _ -> failwith "Invalid Pointer"
+
+let push_constant a = [ addr a; "D=A" ] @ push
+
+let push_pointer a = [ pointer a; "D=M" ] @ push
+
+let push_static offset class_name=
+  [ addr (class_name ^ ":" ^ offset); "D=M" ] @ push
+
+let push_temp a = [ addr a; "D=A"; "@5"; "A=D+A"; "D=M" ] @ push
+
+let pop_pointer a =
+  [ "@SP"; "AM=M-1"; "D=M"; pointer a; "M=D" ]
+
+let pop_static offset class_name =
+  [ "@SP"; "AM=M-1"; "D=M"; addr (class_name ^ ":" ^ offset); "M=D" ]
+
+let push_common segment offset =
+  [ addr offset ; "D=A" ; common segment ; "A=D+M" ; "D=M" ] @ push
+
+let pop_temp a =
+[ addr a; "D=A"; "@5" ; "D=D+A" ] @ pop
+
+let pop_common segment offset = [
+  addr offset
+  ; "D=A"
+  ; common segment
+  ; "D=D+M" ] @ pop
+
+let process_push segment offset class_name =
+  match segment with
+  | Local | Argument | This | That -> push_common segment offset
+  | Constant -> push_constant offset
+  | Temp -> push_temp offset
+  | Static -> push_static class_name offset
+  | Pointer -> push_pointer offset
+
+let process_pop segment offset class_name =
+  match segment with
+  | Local | Argument | This | That -> pop_common segment offset
+  | Temp -> pop_temp offset
+  | Static -> pop_static class_name offset
+  | Pointer -> pop_pointer offset
+  | Constant -> failwith "Invalid Segment"
+
+let translate command segment offset class_name =
+  let offset = Int.to_string offset in
+    match command with
+    | Pop -> process_pop segment offset class_name
+    | Push -> process_push segment offset class_name

compiler/backend/lib/memoryaccess.mli

@@ -0,0 +1,3 @@
+val translate :
+    Ast.memory_command ->
+    Ast.memory_segment -> int -> string -> string list

compiler/backend/lib/parser.mly

@@ -0,0 +1,93 @@
+%{
+open Ast
+%}
+
+
+(* arithmetic and logical commands *)
+%token ADD SUB EQ GT LT AND OR NEG NOT
+
+(* memory commands *)
+%token POP PUSH
+
+(* memory segments *)
+%token CONSTANT STATIC POINTER TEMP
+       ARGUMENT LOCAL THIS THAT
+
+(* branching commands *)
+%token LABEL GOTO IFGOTO
+
+(* function commands*)
+%token FUNCTION CALL RETURN
+
+%token <int> ADDRESS
+%token <string> ID
+%token <string> COMMENT
+%token EOF
+
+%start <Ast.expr> prog
+
+%%
+
+
+prog:
+  | e = expr; EOF                            { e }
+  ;
+
+expr:
+  | c = COMMENT                              { Comment c }
+  | e = arithmetic                           { e }
+  | POP; p = pop                             { p }
+  | PUSH; p = push                           { p }
+  | b = branching                            { b }
+  | FUNCTION; f = function_definition        { f }
+  | CALL; c = function_call                  { c }
+  | RETURN                                   { Return }
+  | e = expr; COMMENT                        { e }
+;
+
+arithmetic:
+  | ADD                             { ArithmeticCommand Add }
+  | SUB                             { ArithmeticCommand Sub }
+  | EQ                              { ArithmeticCommand Eq }
+  | GT                              { ArithmeticCommand Gt }
+  | LT                              { ArithmeticCommand Lt }
+  | AND                             { ArithmeticCommand And }
+  | OR                              { ArithmeticCommand Or }
+  | NEG                             { ArithmeticCommand Neg }
+  | NOT                             { ArithmeticCommand Not }
+;
+
+pop:
+  | ARGUMENT; a = ADDRESS           { MemoryAccessCommand (Pop, Argument, a) }
+  | LOCAL; a = ADDRESS              { MemoryAccessCommand (Pop, Local, a) }
+  | STATIC; a = ADDRESS             { MemoryAccessCommand (Pop, Static, a) }
+  | THIS; a = ADDRESS               { MemoryAccessCommand (Pop, This, a) }
+  | THAT; a = ADDRESS               { MemoryAccessCommand (Pop, That, a) }
+  | POINTER; a = ADDRESS            { MemoryAccessCommand (Pop, Pointer, a) }
+  | TEMP; a = ADDRESS               { MemoryAccessCommand (Pop, Temp, a) }
+;
+
+push:
+  | ARGUMENT; a = ADDRESS           { MemoryAccessCommand (Push, Argument, a) }
+  | LOCAL; a = ADDRESS              { MemoryAccessCommand (Push, Local, a) }
+  | STATIC; a = ADDRESS             { MemoryAccessCommand (Push, Static, a) }
+  | THIS; a = ADDRESS               { MemoryAccessCommand (Push, This, a) }
+  | THAT; a = ADDRESS               { MemoryAccessCommand (Push, That, a) }
+  | POINTER; a = ADDRESS            { MemoryAccessCommand (Push, Pointer, a) }
+  | TEMP; a = ADDRESS               { MemoryAccessCommand (Push, Temp, a) }
+  | CONSTANT; a = ADDRESS           { MemoryAccessCommand (Push, Constant, a) }
+;
+
+branching:
+  | LABEL; i = ID                   { ProgramFlowCommand (Label, i) }
+  | GOTO; i = ID                    { ProgramFlowCommand (Goto, i) }
+  | IFGOTO; i = ID                  { ProgramFlowCommand (Ifgoto, i) }
+;
+
+function_definition:
+  | i = ID; a = ADDRESS             { FunctionCallCommand (Function, i, a) }
+;
+
+function_call:
+  | i = ID; a = ADDRESS             { FunctionCallCommand (Call, i, a) }
+;

compiler/backend/lib/programflow.ml

@@ -0,0 +1,12 @@
+open! Ast
+open! Base
+
+let addr a = "@" ^ a
+
+let label name = "(" ^ name ^ ")"
+
+let translate command name =
+  match command with
+  | Label -> [ label name ]
+  | Goto -> [ addr name; "0;JMP" ]
+  | Ifgoto -> [ "@SP"; "AM=M-1"; "D=M"; addr name; "D;JNE" ]

compiler/backend/lib/programflow.mli

@@ -0,0 +1 @@
+val translate : Ast.branching_command -> string -> string list

compiler/backend/lib/return.ml

@@ -0,0 +1,47 @@
+let translate =
+  [ "// Save LCL to R14, Return Address to R15 "
+  ; "@LCL"
+  ; "D=M"
+  ; "@R14"
+  ; "M=D"
+  ; "@R5"
+  ; "A=D-A"
+  ; "D=M"
+  ; "@R15"
+  ; "M=D"
+  ; "// POP return value to ARG0, SP=ARG+1 "
+  ; "@SP"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@ARG"
+  ; "A=M"
+  ; "M=D"
+  ; "D=A"
+  ; "@SP"
+  ; "M=D+1"
+  ; "// reposition THAT, THIS, ARG, LCL "
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@THAT"
+  ; "M=D"
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@THIS"
+  ; "M=D"
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@ARG"
+  ; "M=D"
+  ; "@R14"
+  ; "AM=M-1"
+  ; "D=M"
+  ; "@LCL"
+  ; "M=D"
+  ; "// Jump to Return Address "
+  ; "@R15"
+  ; "A=M"
+  ; "0;JMP"
+  ]

compiler/backend/lib/return.mli

@@ -0,0 +1 @@
+val translate : string list

compiler/backend/lib/translate.ml

@@ -0,0 +1,27 @@
+open! Ast
+open! Base
+
+let parse str =
+  let lexbuf = Lexing.from_string str in
+  Parser.prog Lexer.read lexbuf
+
+let bootstrap =
+  [ "@256"; "D=A"; "@SP"; "M=D" ]
+  @ Functioncall.translate Call "Sys.init" 0
+
+let translate class_name lines : string list =
+  lines
+  |> List.map ~f:parse
+  |> List.bind ~f:(function
+      | ArithmeticCommand a
+        -> Arithmetic.translate a
+      | MemoryAccessCommand (command, segment, offset)
+        -> Memoryaccess.translate command segment offset class_name
+      | ProgramFlowCommand (command, name)
+        -> Programflow.translate command name
+      | FunctionCallCommand (command, name, arg)
+        -> Functioncall.translate command name arg
+      | Return
+        -> Return.translate
+      | Comment _ -> []
+    )

compiler/backend/lib/translate.mli

@@ -0,0 +1,10 @@
+open Ast
+
+(* Parse a string to the Ast.expr type. *)
+val parse : string -> expr
+
+(* Set the Stack Pointer to 256 and call Sys.init function. *)
+val bootstrap : string list
+
+(* Translate from parsed byte code [Ast.expr] to assembly *)
+val translate : string -> string list -> string list

compiler/backend/test/dune

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

compiler/backend/test/test_backend.ml

@@ -0,0 +1,31 @@
+open OUnit2
+open Backend.Ast
+open Backend.Translate
+
+let peq case value = assert_equal value (parse case)
+
+let test_parse_a_command _ =
+  peq "add" (ArithmeticCommand Add);
+  peq "sub" (ArithmeticCommand Sub);
+  peq "neg" (ArithmeticCommand Neg);
+  peq "eq" (ArithmeticCommand Eq);
+  peq "gt" (ArithmeticCommand Gt);
+  peq "lt" (ArithmeticCommand Lt);
+  peq "and" (ArithmeticCommand And);
+  peq "or" (ArithmeticCommand Or);
+  peq "not" (ArithmeticCommand Not)
+;;
+
+let test_parse_m_command _ =
+  peq "pop local 12" (MemoryAccessCommand (Pop, Local, 12));
+  peq "push argument 4" (MemoryAccessCommand (Push, Argument, 4))
+;;
+
+let suite =
+  "suite"
+  >::: [ "A Instruction" >:: test_parse_a_command
+       ; "M Instruction" >:: test_parse_m_command
+       ]
+;;
+
+let () = run_test_tt_main suite