├── .gitignore ├── README.md ├── asm ├── asm.ml └── dune ├── dune-project ├── firstclassfns.lisp ├── functions.lisp ├── lib ├── ast.ml ├── compile.ml ├── constant_folding.ml ├── dune ├── handparser.ml ├── handparser2.ml ├── interp.ml └── util.ml ├── opt1.lisp ├── opt2.lisp ├── runtime.c └── s_exp ├── dune ├── exp.ml ├── lex.mll ├── parse.mly ├── parser.ml └── s_exp.ml /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | _build 3 | runtime/*.o 4 | .merlin 5 | /output/ 6 | program.o 7 | program 8 | program.s 9 | runtime.o -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The in-class compiler status after (partially!) implementing constant folding. See compiler implementation notes for much more detail. 2 | 3 | To run: 4 | 5 | `dune utop` 6 | 7 | Inside utop: 8 | 9 | `open Cs164.Compile;;` 10 | 11 | ``` 12 | compile_and_run "(print (+ 4 8))";; 13 | ``` 14 | 15 | And remember that you must recompile the runtime if you make changes: 16 | 17 | `gcc -c runtime.c -o runtime.o` 18 | -------------------------------------------------------------------------------- /asm/asm.ml: -------------------------------------------------------------------------------- 1 | type register = Rax | Rcx | R8 | Rsp | Rbp |Rdi 2 | 3 | let string_of_register ?(last_byte = false) (reg : register) : string = 4 | match (reg, last_byte) with 5 | | Rax, false -> 6 | "rax" 7 | | Rax, true -> 8 | "al" 9 | | Rcx, false -> 10 | "rcx" 11 | | Rcx, true -> 12 | "cl" 13 | | R8, false -> 14 | "r8" 15 | | R8, true -> 16 | "r8b" 17 | | Rsp, true -> 18 | "rsp" 19 | | Rsp, false -> 20 | "rsp" 21 | | Rbp, true -> 22 | "rsp" 23 | | Rbp, false -> 24 | "rsp" 25 | | Rdi, true -> 26 | "rdi" 27 | | Rdi, false -> 28 | "rdi" 29 | 30 | type operand = Reg of register | Imm of int | MemOffset of (operand * operand) 31 | 32 | let is_register o = match o with Reg _ -> true | _ -> false 33 | 34 | let rec string_of_operand ?(last_byte = false) = function 35 | | Reg r -> 36 | string_of_register ~last_byte r 37 | | Imm i -> 38 | string_of_int i 39 | | MemOffset (o1, o2) -> 40 | Printf.sprintf "[%s + %s]" (string_of_operand o1) (string_of_operand o2) 41 | 42 | type directive = 43 | | Global of string 44 | | Extern of string 45 | | Label of string 46 | | Align of int 47 | | LeaLabel of (operand * string) 48 | | Mov of (operand * operand) 49 | | Add of (operand * operand) 50 | | Sub of (operand * operand) 51 | | And of (operand * operand) 52 | | Or of (operand * operand) 53 | | Shl of (operand * operand) 54 | | Shr of (operand * operand) 55 | | Cmp of (operand * operand) 56 | | Setz of operand 57 | | Setl of operand 58 | | Jmp of string 59 | | ComputedJmp of operand 60 | | Jz of string 61 | | Jnz of string 62 | | Call of string 63 | | ComputedCall of operand 64 | | Ret 65 | | Comment of string 66 | 67 | let run cmd args = 68 | let open Shexp_process in 69 | let open Shexp_process.Infix in 70 | eval (run cmd args |- read_all) 71 | 72 | let macos = run "uname" ["-s"] |> String.trim |> String.equal "Darwin" 73 | 74 | let label_name macos name = if macos then "_" ^ name else name 75 | 76 | let string_of_directive = function 77 | (* frontmatter *) 78 | | Global l -> 79 | Printf.sprintf 80 | (if macos then "default rel\nglobal %s" else "global %s") 81 | (label_name macos l) 82 | | Extern l -> 83 | Printf.sprintf "extern %s" (label_name macos l) 84 | (* labels *) 85 | | Label l -> 86 | label_name macos l ^ ":" 87 | | Align i -> 88 | Printf.sprintf "align %d" i 89 | (* actual instructions *) 90 | | LeaLabel (dest, label) -> 91 | Printf.sprintf "\tlea %s, [%s]" (string_of_operand dest) 92 | (label_name macos label) 93 | | Mov (dest, src) -> 94 | Printf.sprintf "\tmov %s, %s" (string_of_operand dest) 95 | (string_of_operand src) 96 | | Add (dest, src) -> 97 | Printf.sprintf "\tadd %s, %s" (string_of_operand dest) 98 | (string_of_operand src) 99 | | Sub (dest, src) -> 100 | Printf.sprintf "\tsub %s, %s" (string_of_operand dest) 101 | (string_of_operand src) 102 | | And (dest, src) -> 103 | Printf.sprintf "\tand %s, %s" (string_of_operand dest) 104 | (string_of_operand src) 105 | | Or (dest, src) -> 106 | Printf.sprintf "\tor %s, %s" (string_of_operand dest) 107 | (string_of_operand src) 108 | | Shl (dest, src) -> 109 | Printf.sprintf "\tshl %s, %s" (string_of_operand dest) 110 | (string_of_operand src) 111 | | Shr (dest, src) -> 112 | Printf.sprintf "\tshr %s, %s" (string_of_operand dest) 113 | (string_of_operand src) 114 | | Cmp (dest, src) -> 115 | Printf.sprintf "\tcmp %s, %s" (string_of_operand dest) 116 | (string_of_operand src) 117 | | Setz dest -> 118 | Printf.sprintf "\tsetz %s" (string_of_operand ~last_byte:true dest) 119 | | Setl dest -> 120 | Printf.sprintf "\tsetl %s" (string_of_operand ~last_byte:true dest) 121 | | Jmp name -> 122 | Printf.sprintf "\tjmp %s" (label_name macos name) 123 | | ComputedJmp op -> 124 | Printf.sprintf "\tjmp %s" (string_of_operand op) 125 | | Jz name -> 126 | Printf.sprintf "\tjz %s" (label_name macos name) 127 | | Jnz name -> 128 | Printf.sprintf "\tjnz %s" (label_name macos name) 129 | | Call name -> 130 | Printf.sprintf "\tcall %s" (label_name macos name) 131 | | ComputedCall op -> 132 | Printf.sprintf "\tcall %s" (string_of_operand op) 133 | | Ret -> 134 | "\tret" 135 | | Comment s -> 136 | Printf.sprintf "; %s" s -------------------------------------------------------------------------------- /asm/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name asm) 3 | (preprocess 4 | (pps ppx_deriving.show ppx_deriving.eq ppx_inline_test ppx_let ppx_blob)) 5 | (libraries shexp.process)) 6 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | 3 | (name cs164) 4 | 5 | (using menhir 2.1) 6 | -------------------------------------------------------------------------------- /firstclassfns.lisp: -------------------------------------------------------------------------------- 1 | (define (f g) (g 2)) 2 | (define (mul2 x) (+ x x)) 3 | (print (f mul2)) 4 | 5 | (define (mul2 x) (+ x x)) 6 | (let ((newname mul2)) (print (newname 5))) 7 | 8 | (define (range lo hi) 9 | (if (< lo hi) 10 | (pair lo (range (add1 lo) hi)) 11 | false)) 12 | (define (map f l) 13 | (if (not l) l 14 | (pair (f (left l)) (map f (right l))))) 15 | (define (g x) (+ x 1)) 16 | (print (map g (range 0 4))) 17 | 18 | ------- 19 | 20 | (define (f g) (g 2)) 21 | (print (f (lambda (x) (+ x x)))) 22 | 23 | (define (range lo hi) 24 | (if (< lo hi) 25 | (pair lo (range (add1 lo) hi)) 26 | false)) 27 | (define (map f l) 28 | (if (not l) l 29 | (pair (f (left l)) (map f (right l))))) 30 | (print (map (lambda (x) (+ x 1)) (range 0 4))) 31 | 32 | ------- 33 | 34 | (define (f g) (g 2)) 35 | (let ((y 3)) (print (f (lambda (x) (+ x y))))) 36 | 37 | (define (retlam) 38 | (let ((x 3)) 39 | (lambda () x) 40 | ) 41 | ) 42 | (let ((l (retlam))) 43 | (print (l)) 44 | ) 45 | 46 | ------- 47 | for discussion 48 | 49 | (define (f a) (+ a b)) 50 | (print (f 2)) 51 | 52 | (define (sum-to x) 53 | (if (= x 0) 54 | 0 55 | (+ x (sum-to (sub1 x))) 56 | )) 57 | (print (sum-to 700)) -------------------------------------------------------------------------------- /functions.lisp: -------------------------------------------------------------------------------- 1 | ;; Example 1 2 | 3 | (define (id x) x) 4 | (print (id 4)) 5 | 6 | ;; Example 2 7 | 8 | (define (f x y) (+ x y)) 9 | (define (g x) (f x x)) 10 | (print (f 4 5)) 11 | 12 | ;; Example 3 13 | 14 | (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) 15 | (print (fib (read-num))) 16 | 17 | ;; Example 4 18 | 19 | (define (even n) (if (zero? n) true (odd (sub1 n)))) 20 | (define (odd n) (if (zero? n) false (even (sub1 n)))) 21 | (print (even (read-num))) 22 | 23 | ;; Example 5.0 24 | 25 | (define (sum n) 26 | (if (zero? n) 27 | n 28 | (+ n (sum (sub1 n))))) 29 | (print (sum (read-num))) 30 | 31 | ;; Example 5.1 32 | 33 | (define (sum n total) 34 | (if (zero? n) 35 | total 36 | (sum (sub1 n) (+ n total)))) 37 | (print (sum (read-num) 0)) 38 | 39 | ;; Example 6 40 | 41 | (define (f x) (+ 3 x)) 42 | (define (sum-f n total) 43 | (if (zero? n) 44 | total 45 | (sum-f (sub1 n) (+ (f n) total)))) 46 | (print (sum-f (read-num) 0)) -------------------------------------------------------------------------------- /lib/ast.ml: -------------------------------------------------------------------------------- 1 | open S_exp 2 | open Util 3 | 4 | type prim0 = ReadNum | Newline 5 | 6 | let prim0_of_string = function 7 | | "read-num" -> 8 | Some ReadNum 9 | | "newline" -> 10 | Some Newline 11 | | _ -> 12 | None 13 | 14 | type prim1 = Add1 | Sub1 | ZeroP | NumP | Not | Left | Right | Print 15 | 16 | let prim1_of_string = function 17 | | "add1" -> 18 | Some Add1 19 | | "sub1" -> 20 | Some Sub1 21 | | "zero?" -> 22 | Some ZeroP 23 | | "num?" -> 24 | Some NumP 25 | | "not" -> 26 | Some Not 27 | | "left" -> 28 | Some Left 29 | | "right" -> 30 | Some Right 31 | | "print" -> 32 | Some Print 33 | | _ -> 34 | None 35 | 36 | type prim2 = Plus | Minus | Eq | Lt | Pair 37 | 38 | let prim2_of_string = function 39 | | "+" -> 40 | Some Plus 41 | | "-" -> 42 | Some Minus 43 | | "=" -> 44 | Some Eq 45 | | "<" -> 46 | Some Lt 47 | | "pair" -> 48 | Some Pair 49 | | _ -> 50 | None 51 | 52 | type expr = 53 | | Prim0 of prim0 54 | | Prim1 of prim1 * expr 55 | | Prim2 of prim2 * expr * expr 56 | | Let of string * expr * expr 57 | | If of expr * expr * expr 58 | | Do of expr list 59 | | Num of int 60 | | Var of string 61 | | Call of expr * expr list 62 | | True 63 | | False 64 | | Closure of string 65 | 66 | type expr_lam = 67 | | Prim0 of prim0 68 | | Prim1 of prim1 * expr_lam 69 | | Prim2 of prim2 * expr_lam * expr_lam 70 | | Let of string * expr_lam * expr_lam 71 | | If of expr_lam * expr_lam * expr_lam 72 | | Do of expr_lam list 73 | | Num of int 74 | | Var of string 75 | | Call of expr_lam * expr_lam list 76 | | True 77 | | False 78 | | Lambda of string list * expr_lam 79 | 80 | type defn = {name: string; args: string list; body: expr; toplevel: bool; offset: int} 81 | 82 | type program = {defns: defn list; body: expr} 83 | 84 | let is_defn defns name = List.exists (fun d -> d.name = name) defns 85 | 86 | let get_defn defns name = List.find (fun d -> d.name = name) defns 87 | 88 | let is_sym e = match e with Sym _ -> true | _ -> false 89 | 90 | let as_sym e = match e with Sym s -> s | _ -> raise Not_found 91 | 92 | let rec expr_lam_of_s_exp : s_exp -> expr_lam = function 93 | | Num x -> 94 | Num x 95 | | Sym "true" -> 96 | True 97 | | Sym "false" -> 98 | False 99 | | Sym var -> 100 | Var var 101 | | Lst [Sym "let"; Lst [Lst [Sym var; exp]]; body] -> 102 | Let (var, expr_lam_of_s_exp exp, expr_lam_of_s_exp body) 103 | | Lst (Sym "do" :: exps) when List.length exps > 0 -> 104 | Do (List.map expr_lam_of_s_exp exps) 105 | | Lst [Sym "if"; test_s; then_s; else_s] -> 106 | If 107 | ( expr_lam_of_s_exp test_s 108 | , expr_lam_of_s_exp then_s 109 | , expr_lam_of_s_exp else_s ) 110 | | Lst [Sym "lambda"; Lst args; body] when List.for_all is_sym args -> 111 | Lambda (List.map as_sym args, expr_lam_of_s_exp body) 112 | | Lst [Sym prim] when Option.is_some (prim0_of_string prim) -> 113 | Prim0 (Option.get (prim0_of_string prim)) 114 | | Lst [Sym prim; arg] when Option.is_some (prim1_of_string prim) -> 115 | Prim1 (Option.get (prim1_of_string prim), expr_lam_of_s_exp arg) 116 | | Lst [Sym prim; arg1; arg2] when Option.is_some (prim2_of_string prim) -> 117 | Prim2 118 | ( Option.get (prim2_of_string prim) 119 | , expr_lam_of_s_exp arg1 120 | , expr_lam_of_s_exp arg2 ) 121 | | Lst (f :: args) -> 122 | Call (expr_lam_of_s_exp f, List.map expr_lam_of_s_exp args) 123 | | e -> 124 | raise (BadSExpression e) 125 | 126 | let rec expr_of_expr_lam (defns : defn list ref) : expr_lam -> expr = function 127 | | Num x -> 128 | Num x 129 | | Var s -> 130 | Var s 131 | | True -> 132 | True 133 | | False -> 134 | False 135 | | If (test_exp, then_exp, else_exp) -> 136 | If 137 | ( expr_of_expr_lam defns test_exp 138 | , expr_of_expr_lam defns then_exp 139 | , expr_of_expr_lam defns else_exp ) 140 | | Let (var, exp, body) -> 141 | Let (var, expr_of_expr_lam defns exp, expr_of_expr_lam defns body) 142 | | Prim0 p -> 143 | Prim0 p 144 | | Prim1 (p, e) -> 145 | Prim1 (p, expr_of_expr_lam defns e) 146 | | Prim2 (p, e1, e2) -> 147 | Prim2 (p, expr_of_expr_lam defns e1, expr_of_expr_lam defns e2) 148 | | Do exps -> 149 | Do (List.map (expr_of_expr_lam defns) exps) 150 | | Call (exp, args) -> 151 | Call (expr_of_expr_lam defns exp, List.map (expr_of_expr_lam defns) args) 152 | | Lambda (args, body) -> 153 | let name = gensym "_lambda" in 154 | defns := {name; args; body=expr_of_expr_lam defns body; toplevel=false; offset=0} :: !defns; 155 | Closure name 156 | 157 | let program_of_s_exps (exps : s_exp list) : program = 158 | let defns = ref [] in 159 | let rec get_args args = 160 | match args with 161 | | Sym v :: args -> 162 | v :: get_args args 163 | | e :: _ -> 164 | raise (BadSExpression e) 165 | | [] -> 166 | [] 167 | in 168 | let counter = ref 0 in 169 | let get_defn = function 170 | | Lst [Sym "define"; Lst (Sym name :: args); body] -> 171 | let args = get_args args in 172 | let defn = {name; args; body= body |> expr_lam_of_s_exp |> expr_of_expr_lam defns; toplevel = true; offset = !counter} in 173 | counter := !counter + 8 ; 174 | defn 175 | | e -> 176 | raise (BadSExpression e) 177 | in 178 | let rec go exps = 179 | match exps with 180 | | [e] -> 181 | let body = e |> expr_lam_of_s_exp |> expr_of_expr_lam defns in 182 | {defns= List.rev !defns; body} 183 | | d :: exps -> 184 | let defn = get_defn d in 185 | defns := defn :: !defns ; 186 | go exps 187 | | _ -> 188 | raise (BadSExpression (Sym "empty")) 189 | in 190 | go exps 191 | 192 | exception BadExpression of expr -------------------------------------------------------------------------------- /lib/compile.ml: -------------------------------------------------------------------------------- 1 | open S_exp 2 | open Ast 3 | open Asm 4 | open Interp 5 | open Util 6 | 7 | let num_shift = 2 8 | let num_mask = 0b11 9 | let num_tag = 0b00 10 | 11 | let bool_shift = 7 12 | let bool_mask = 0b1111111 13 | let bool_tag = 0b0011111 14 | 15 | let heap_mask = 0b111 16 | let pair_tag = 0b010 17 | let fn_tag = 0b110 18 | 19 | let operand_of_bool (b: bool) : operand = 20 | Imm (((if b then 1 else 0) lsl bool_shift) lor bool_tag) 21 | 22 | let operand_of_num (x: int) : operand = 23 | Imm ((x lsl num_shift) lor num_tag) 24 | 25 | let zf_to_bool : directive list = 26 | [Mov (Reg Rax, Imm 0) 27 | ; Setz (Reg Rax) 28 | ; Shl (Reg Rax, Imm bool_shift) 29 | ; Or (Reg Rax, Imm bool_tag)] 30 | 31 | let lf_to_bool : directive list = 32 | [ Mov (Reg Rax, Imm 0) 33 | ; Setl (Reg Rax) 34 | ; Shl (Reg Rax, Imm bool_shift) 35 | ; Or (Reg Rax, Imm bool_tag) 36 | ] 37 | 38 | let ensure_num (op : operand) : directive list = 39 | [ 40 | Mov (Reg R8, op) 41 | ;And (Reg R8, Imm num_mask) 42 | ; Cmp (Reg R8, Imm num_tag) 43 | ; Jnz "error" 44 | ] 45 | 46 | let ensure_pair (op : operand) : directive list = 47 | [ 48 | Mov (Reg R8, op) 49 | ;And (Reg R8, Imm heap_mask) 50 | ; Cmp (Reg R8, Imm pair_tag) 51 | ; Jnz "error" 52 | ] 53 | 54 | let ensure_fn (op : operand) : directive list = 55 | [ 56 | Mov (Reg R8, op) 57 | ;And (Reg R8, Imm heap_mask) 58 | ; Cmp (Reg R8, Imm fn_tag) 59 | ; Jnz "error" 60 | ] 61 | 62 | let stack_address (stack_index : int) = MemOffset (Reg Rsp, Imm stack_index) 63 | 64 | let align_stack_index (stack_index : int) : int = 65 | if stack_index mod 16 = -8 then stack_index else stack_index - 8 66 | 67 | let rec fv (defns : defn list) (bound: string list) (exp : expr) = 68 | match exp with 69 | | Var s when not (List.mem s bound) -> 70 | [s] 71 | | Let (v, e, body) -> 72 | fv defns bound e @ fv defns (v::bound) body 73 | | If (te, the, ee) -> 74 | fv defns bound te @ fv defns bound the @ fv defns bound ee 75 | | Do es -> 76 | List.concat_map (fv defns bound) es 77 | | Call (exp, args) -> 78 | fv defns bound exp @ List.concat_map (fv defns bound) args 79 | | Prim1 (_, e) -> 80 | fv defns bound e 81 | | Prim2 (_, e1, e2) -> 82 | fv defns bound e1 @ fv defns bound e2 83 | | Closure f -> 84 | let defn = get_defn defns f in 85 | fv defns (bound @ List.map (fun d -> d.name) defns @ defn.args) defn.body 86 | | _ -> 87 | [] 88 | 89 | let rec compile_exp (defns : defn list) (tab : int symtab) (stack_index: int) (program: expr) (is_tail : bool): directive list = 90 | match program with 91 | | Num n -> 92 | [Mov (Reg Rax, operand_of_num n)] 93 | | True -> [Mov (Reg Rax, operand_of_bool true)] 94 | | False -> [Mov (Reg Rax, operand_of_bool false)] 95 | | Call (f, args) when not is_tail -> 96 | let stack_base = align_stack_index (stack_index + 8) in 97 | let compiled_args = 98 | args 99 | |> List.mapi (fun i arg -> 100 | compile_exp defns tab (stack_base - ((i+2) * 8)) arg false 101 | @ [Mov (stack_address (stack_base - ((i+2) * 8)), Reg Rax)] 102 | ) 103 | |> List.concat in 104 | compiled_args 105 | @ compile_exp defns tab (stack_base - ((List.length args +2) * 8)) f false 106 | @ ensure_fn (Reg Rax) 107 | @ [ Mov (stack_address (stack_base - (8 * (List.length args + 2))), Reg Rax); 108 | Sub (Reg Rax, Imm fn_tag); 109 | Mov (Reg Rax, MemOffset (Reg Rax, Imm 0)) 110 | ] 111 | @ [ 112 | Add (Reg Rsp, Imm stack_base); 113 | ComputedCall (Reg Rax); 114 | Sub (Reg Rsp, Imm stack_base); 115 | ] 116 | | Call (f, args) when is_tail -> 117 | let compiled_args = 118 | args 119 | |> List.mapi (fun i arg -> 120 | compile_exp defns tab (stack_index - (8*i)) arg false 121 | @ [Mov (stack_address (stack_index - (8*i)), Reg Rax)] 122 | ) 123 | |> List.concat in 124 | let moved_args = 125 | args 126 | |> List.mapi (fun i _ -> 127 | [Mov (Reg R8, stack_address (stack_index - (8*i))) 128 | ; Mov (stack_address ((i + 1) * -8), Reg R8)] 129 | ) 130 | |> List.concat in 131 | compiled_args 132 | @ compile_exp defns tab (stack_index - (8 * List.length args)) f false 133 | @ ensure_fn (Reg Rax) @ moved_args 134 | @ [ Mov (stack_address ((List.length args + 1) * -8), Reg Rax); 135 | Sub (Reg Rax, Imm fn_tag); 136 | Mov (Reg Rax, MemOffset (Reg Rax, Imm 0))] 137 | @ [ComputedJmp (Reg Rax);] 138 | | Call _ -> raise (BadExpression program) 139 | | Prim2 (Pair, e1, e2) -> 140 | compile_exp defns tab stack_index e1 false 141 | @ [Mov (stack_address stack_index, Reg Rax)] 142 | @ compile_exp defns tab (stack_index - 8) e2 false 143 | @ [Mov (Reg R8, stack_address stack_index) 144 | ; Mov (MemOffset (Reg Rdi, Imm 0), Reg R8) 145 | ; Mov (MemOffset (Reg Rdi, Imm 8), Reg Rax) 146 | ; Mov (Reg Rax, Reg Rdi) 147 | ; Or (Reg Rax, Imm pair_tag) 148 | ; Add (Reg Rdi, Imm 16) 149 | ] 150 | | Prim0 ReadNum -> 151 | [ 152 | Mov (stack_address stack_index, Reg Rdi); 153 | Add (Reg Rsp, Imm (align_stack_index stack_index)); 154 | Call "read_num"; 155 | Sub (Reg Rsp, Imm (align_stack_index stack_index)); 156 | Mov (Reg Rdi, stack_address stack_index); 157 | ] 158 | | Do exps -> 159 | List.mapi (fun i exp -> 160 | compile_exp defns tab stack_index exp 161 | (if i = List.length exps - 1 then is_tail else false)) 162 | exps 163 | |> List.concat 164 | | Prim1 (Print, e) -> 165 | compile_exp defns tab stack_index e false @ 166 | [ 167 | Mov (stack_address stack_index, Reg Rdi); 168 | Mov (Reg Rdi, Reg Rax); 169 | Add (Reg Rsp, Imm (align_stack_index stack_index)); 170 | Call "print_value"; 171 | Sub (Reg Rsp, Imm (align_stack_index stack_index)); 172 | Mov (Reg Rdi, stack_address stack_index); 173 | Mov (Reg Rax, operand_of_bool true) 174 | ] 175 | | Prim0 Newline -> 176 | [ 177 | Mov (stack_address stack_index, Reg Rdi); 178 | Add (Reg Rsp, Imm (align_stack_index stack_index)); 179 | Call "print_newline"; 180 | Sub (Reg Rsp, Imm (align_stack_index stack_index)); 181 | Mov (Reg Rdi, stack_address stack_index); 182 | Mov (Reg Rax, operand_of_bool true) 183 | ] 184 | | Prim1 (Left, e) -> 185 | compile_exp defns tab stack_index e false 186 | @ ensure_pair (Reg Rax) 187 | @ [Mov (Reg Rax, MemOffset (Reg Rax, Imm (-pair_tag)))] 188 | | Prim1 (Right, e) -> 189 | compile_exp defns tab stack_index e false 190 | @ ensure_pair (Reg Rax) 191 | @ [Mov (Reg Rax, MemOffset (Reg Rax, Imm (-pair_tag + 8)))] 192 | | Let (var, e, body) -> 193 | compile_exp defns tab stack_index e false 194 | @ [Mov (stack_address stack_index, Reg Rax)] 195 | @ compile_exp defns (Symtab.add var stack_index tab) (stack_index - 8) body is_tail 196 | | Var var when Symtab.mem var tab -> 197 | [Mov (Reg Rax, stack_address (Symtab.find var tab))] 198 | | Var var when is_defn defns var -> 199 | [ 200 | Mov (Reg Rax, Reg Rcx) 201 | ; Add (Reg Rax, Imm (get_defn defns var).offset) 202 | ; Or (Reg Rax, Imm fn_tag) 203 | ] 204 | | Var _ -> raise (BadExpression program) 205 | | Closure f -> 206 | let defn = get_defn defns f in 207 | let fvs = fv defns (List.map (fun d -> d.name) defns @ defn.args) defn.body in 208 | let fv_movs = 209 | List.mapi 210 | (fun i var -> 211 | [ 212 | Mov (Reg Rax, stack_address (Symtab.find var tab)); 213 | Mov (MemOffset (Reg Rdi, Imm (8* (i + 1))), Reg Rax) 214 | ] 215 | ) 216 | fvs 217 | in 218 | if List.exists (fun v -> not (Symtab.mem v tab)) fvs then 219 | raise (BadExpression program) 220 | else 221 | [LeaLabel (Reg Rax, defn_label f); 222 | Mov (MemOffset (Reg Rdi, Imm 0), Reg Rax) 223 | ] 224 | @ List.concat fv_movs 225 | @ [Mov (Reg Rax, Reg Rdi) 226 | ; Or (Reg Rax, Imm fn_tag) 227 | ; Add (Reg Rdi, Imm (8*(List.length fvs + 1))) 228 | ] 229 | | Prim1 (Not, arg) -> 230 | compile_exp defns tab stack_index arg false @ 231 | [Cmp (Reg Rax, operand_of_bool false)] 232 | @ zf_to_bool 233 | | Prim1 (ZeroP, arg) -> 234 | compile_exp defns tab stack_index arg false @ 235 | [Cmp (Reg Rax, operand_of_num 0)] 236 | @ zf_to_bool 237 | | Prim1 (NumP, arg) -> 238 | compile_exp defns tab stack_index arg false @ 239 | [And (Reg Rax, Imm num_mask); Cmp (Reg Rax, Imm num_tag)] 240 | @ zf_to_bool 241 | | Prim1 (Add1, arg) -> 242 | compile_exp defns tab stack_index arg false @ 243 | ensure_num (Reg Rax) @ 244 | [Add (Reg Rax, operand_of_num 1)] 245 | | Prim1 (Sub1, arg) -> 246 | compile_exp defns tab stack_index arg false @ 247 | ensure_num (Reg Rax) @ 248 | [Sub (Reg Rax, operand_of_num 1)] 249 | | If (test_exp, then_exp, else_exp) -> 250 | let else_label = Util.gensym "else" in 251 | let continue_label = Util.gensym "continue" in 252 | compile_exp defns tab stack_index test_exp false 253 | @ [Cmp (Reg Rax, operand_of_bool false); Jz else_label] 254 | @ compile_exp defns tab stack_index then_exp is_tail 255 | @ [Jmp continue_label] 256 | @ [Label else_label] 257 | @ compile_exp defns tab stack_index else_exp is_tail 258 | @ [Label continue_label] 259 | | Prim2 (Plus, e1, e2) -> ( 260 | compile_exp defns tab stack_index e1 false 261 | @ ensure_num (Reg Rax) 262 | @ [Mov (MemOffset (Reg Rsp, Imm stack_index), Reg Rax)] 263 | @ compile_exp defns tab (stack_index - 8) e2 false 264 | @ ensure_num (Reg Rax) 265 | @ [Mov (Reg R8, MemOffset (Reg Rsp, Imm stack_index))] 266 | @ [Add (Reg Rax, Reg R8)] 267 | ) 268 | | Prim2 (Minus, e1, e2) -> ( 269 | compile_exp defns tab stack_index e1 false 270 | @ ensure_num (Reg Rax) 271 | @ [Mov (MemOffset (Reg Rsp, Imm stack_index), Reg Rax)] 272 | @ compile_exp defns tab (stack_index - 8) e2 false 273 | @ ensure_num (Reg Rax) 274 | @ [Mov (Reg R8, Reg Rax)] 275 | @ [Mov (Reg Rax, MemOffset (Reg Rsp, Imm stack_index))] 276 | @ [Sub (Reg Rax, Reg R8)] 277 | ) 278 | | Prim2 (Eq, e1, e2) -> ( 279 | compile_exp defns tab stack_index e1 false 280 | @ ensure_num (Reg Rax) 281 | @ [Mov (MemOffset (Reg Rsp, Imm stack_index), Reg Rax)] 282 | @ compile_exp defns tab (stack_index - 8) e2 false 283 | @ ensure_num (Reg Rax) 284 | @ [Mov (Reg R8, MemOffset (Reg Rsp, Imm stack_index))] 285 | @ [Cmp (Reg Rax, Reg R8)] 286 | @ zf_to_bool 287 | ) 288 | | Prim2 (Lt, e1, e2) -> ( 289 | compile_exp defns tab stack_index e1 false 290 | @ ensure_num (Reg Rax) 291 | @ [Mov (MemOffset (Reg Rsp, Imm stack_index), Reg Rax)] 292 | @ compile_exp defns tab (stack_index - 8) e2 false 293 | @ ensure_num (Reg Rax) 294 | @ [Mov (Reg R8, MemOffset (Reg Rsp, Imm stack_index))] 295 | @ [Cmp (Reg R8, Reg Rax)] 296 | @ lf_to_bool 297 | ) 298 | 299 | let compile_defn defns defn = 300 | let fvs = fv defns (List.map (fun d -> d.name) defns @ defn.args) defn.body in 301 | if List.length fvs > 0 && defn.toplevel 302 | then raise (BadExpression defn.body) 303 | else 304 | let ftab = 305 | defn.args @ fvs 306 | |> List.mapi (fun i arg -> (arg, -8 * (i + 1))) 307 | |> Symtab.of_list 308 | in 309 | let fvs_to_stack = 310 | [ 311 | Mov (Reg Rax, stack_address (-8 * (List.length defn.args + 1))) 312 | ; Sub (Reg Rax, Imm fn_tag) 313 | ; Add (Reg Rax, Imm 8) 314 | ; 315 | ] 316 | @ List.concat 317 | (List.mapi 318 | (fun i _ -> 319 | [Mov (Reg R8, MemOffset (Reg Rax, Imm (i * 8))) 320 | ; Mov (stack_address (-8 * (List.length defn.args + 1 + i)), Reg R8)] 321 | ) 322 | fvs) 323 | in 324 | [Align 8; Label (defn_label defn.name)] 325 | @ fvs_to_stack 326 | @ compile_exp defns ftab (-8 * (Symtab.cardinal ftab + 1)) defn.body true 327 | @ [Ret] 328 | 329 | let compile_toplevel_closure defn = 330 | [ LeaLabel (Reg Rax, defn_label defn.name) 331 | ; Mov (MemOffset (Reg Rdi, Imm defn.offset), Reg Rax) 332 | ] 333 | 334 | let compile (program:s_exp list): string = 335 | let prog = program_of_s_exps program in 336 | let prog = Constant_folding.fold_program prog in 337 | let toplevel_funcs = List.filter (fun defn -> defn.toplevel) prog.defns in 338 | [Global "entry"; 339 | Extern "error"; 340 | Extern "read_num"; 341 | Extern "print_newline"; 342 | Extern "print_value"; 343 | Label "entry"; 344 | Mov (Reg Rcx, Reg Rdi)] 345 | @ List.concat (List.map 346 | (fun defn -> compile_toplevel_closure defn) toplevel_funcs) 347 | @ [Add (Reg Rdi, Imm (List.length toplevel_funcs * 8))] 348 | @ compile_exp prog.defns Symtab.empty (-8) prog.body true 349 | @ [Ret] 350 | @ List.concat_map (compile_defn prog.defns) prog.defns 351 | |> List.map string_of_directive |> String.concat "\n" 352 | 353 | let compile_to_file (program: string): unit = 354 | let file = open_out "program.s" in 355 | output_string file (compile (parse_many program)); 356 | close_out file 357 | 358 | let compile_and_run (program: string): string = 359 | compile_to_file program; 360 | ignore (Unix.system "nasm program.s -f macho64 -o program.o"); 361 | ignore (Unix.system "gcc program.o runtime.o -o program"); 362 | let inp = Unix.open_process_in "./program" in 363 | let r = input_line inp in 364 | close_in inp; r 365 | 366 | let compile_and_run_io (program : string) (input : string) : string = 367 | compile_to_file program ; 368 | ignore (Unix.system "nasm program.s -f macho64 -o program.o") ; 369 | ignore (Unix.system "gcc program.o runtime.c -o program") ; 370 | let inp, outp = Unix.open_process "./program" in 371 | output_string outp input ; 372 | close_out outp ; 373 | let r = input_all inp in 374 | close_in inp ; r 375 | 376 | let compile_and_run_err (program : string) (input : string) : string = 377 | try compile_and_run_io program input with BadExpression _ -> "ERROR" 378 | 379 | let difftest (examples : (string * string) list) = 380 | let results = List.map (fun (ex, i) -> (compile_and_run_err ex i, interp_err ex i)) examples in 381 | List.for_all (fun (r1, r2) -> r1 = r2) results 382 | 383 | let test () = 384 | difftest [ 385 | ("32", "") 386 | ; ("(add1 (add1 40))" , "") 387 | ; ("(sub1 43)", "") 388 | ; ("(not 3)", "") 389 | ; ("(not (not false))", "") 390 | ; ("(not (zero? 4))", "") 391 | ; ("(num? (add1 3))", "") 392 | ; ("(+ 1 3)", "") 393 | ; ("(+ false true)", "") 394 | ; ("(add1 false)", "") 395 | ; ("(sub1 false)", "") 396 | ; ("(= (pair 1 2) (pair 1 2))", "") 397 | ; ("(= 3 3)", "") 398 | ; ("(print (read-num))", "1") 399 | ] -------------------------------------------------------------------------------- /lib/constant_folding.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | let rec fold : expr -> expr = function 4 | | Prim1 (Add1, e) -> ( 5 | let e = fold e in 6 | match e with Num n -> Num (n+1) | _ -> Prim1 (Add1, e) 7 | ) 8 | | Prim1 (Sub1, e) -> ( 9 | let e = fold e in 10 | match e with Num n -> Num (n-1) | _ -> Prim1 (Sub1, e) 11 | ) 12 | | Prim1 (p, e) -> 13 | Prim1 (p, fold e) 14 | | Prim2 (Plus, e1, e2) -> ( 15 | let e1 = fold e1 in 16 | let e2 = fold e2 in 17 | match (e1, e2) with 18 | | Num x, Num y -> 19 | Num (x + y) 20 | | _ -> 21 | Prim2 (Plus, e1, e2) 22 | ) 23 | | Prim2 (p, e1, e2) -> 24 | Prim2 (p, fold e1, fold e2) 25 | | If (e1, e2, e3) -> 26 | If (fold e1, fold e2, fold e3) 27 | | Let (v, e, b) -> 28 | Let (v, fold e, fold b) 29 | | e -> e 30 | 31 | 32 | let fold_program (prog: program) = 33 | {body = fold prog.body; 34 | defns = 35 | List.map 36 | (fun {name; args; body; toplevel; offset} -> {name; args; body = fold body; toplevel; offset}) 37 | prog.defns 38 | } -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cs164) 3 | (libraries s_exp asm)) 4 | -------------------------------------------------------------------------------- /lib/handparser.ml: -------------------------------------------------------------------------------- 1 | type s_exp = Num of int | Sym of string | Lst of s_exp list 2 | 3 | type token = NUM of int | SYM of string | LPAREN | RPAREN 4 | 5 | exception ParseError 6 | 7 | let token_of_string (s : string) = 8 | match s with 9 | | "(" -> 10 | LPAREN 11 | | ")" -> 12 | RPAREN 13 | | _ -> ( 14 | try NUM (int_of_string s) with _ -> SYM s ) 15 | 16 | let tokenize (s : string) = 17 | s |> String.split_on_char ' ' |> List.map token_of_string 18 | 19 | let rec parse_s_exp (toks : token list) : s_exp * token list = 20 | match toks with 21 | | NUM n :: toks2 -> (Num n, toks2) 22 | | SYM s :: toks2 -> (Sym s, toks2) 23 | | LPAREN :: toks2 -> 24 | let exps3, toks3 = parse_lst toks2 in 25 | (Lst exps3, toks3) 26 | | _ -> raise ParseError 27 | 28 | and parse_lst (toks : token list) : s_exp list * token list = 29 | match toks with 30 | | RPAREN :: toks2 -> ([], toks2) 31 | | _ -> 32 | let exp2, toks2 = parse_s_exp toks in 33 | let exps3, toks3 = parse_lst toks2 in 34 | (exp2 :: exps3, toks3) 35 | 36 | let parse (s : string) : s_exp = 37 | let toks = tokenize s in 38 | let exp, l = parse_s_exp toks in 39 | if List.length l = 0 then exp else raise ParseError 40 | 41 | 42 | -------------------------------------------------------------------------------- /lib/handparser2.ml: -------------------------------------------------------------------------------- 1 | type token = PLUS | TIMES | LPAREN | RPAREN | NUM of int 2 | 3 | type expr = Num of int | Plus of expr * expr | Times of expr * expr 4 | 5 | exception ParseError 6 | 7 | let token_of_string (s : string) = 8 | match s with 9 | | "(" -> 10 | LPAREN 11 | | ")" -> 12 | RPAREN 13 | | "+" -> 14 | PLUS 15 | | "*" -> 16 | TIMES 17 | | _ -> ( 18 | NUM (int_of_string s)) 19 | 20 | let tokenize (s : string) = 21 | s |> String.split_on_char ' ' |> List.map token_of_string 22 | 23 | let rec parse_expr toks = 24 | let t, toks = parse_term toks in 25 | parse_expr_prime t toks 26 | 27 | and parse_expr_prime t toks = 28 | match toks with 29 | | PLUS :: toks -> 30 | let e, toks = parse_expr toks in 31 | (Plus (t, e), toks) 32 | | _ -> 33 | (t, toks) 34 | 35 | and parse_term toks = 36 | let f, toks = parse_factor toks in 37 | parse_term_prime f toks 38 | 39 | and parse_term_prime f toks = 40 | match toks with 41 | | TIMES :: toks -> 42 | let e, toks = parse_term toks in 43 | (Times (f, e), toks) 44 | | _ -> 45 | (f, toks) 46 | 47 | and parse_factor toks = 48 | match toks with 49 | | NUM n :: toks -> 50 | (Num n, toks) 51 | | LPAREN :: toks -> ( 52 | let e, toks = parse_expr toks in 53 | match toks with RPAREN :: toks -> (e, toks) | _ -> raise ParseError ) 54 | | _ -> 55 | raise ParseError 56 | 57 | let parse (s : string) = 58 | let toks = tokenize s in 59 | let exp, l = parse_expr toks in 60 | if List.length l = 0 then exp else raise ParseError -------------------------------------------------------------------------------- /lib/interp.ml: -------------------------------------------------------------------------------- 1 | open S_exp 2 | open Ast 3 | open Util 4 | 5 | type value = 6 | Number of int 7 | | Boolean of bool 8 | | Pair of (value * value) 9 | | Function of (string * value symtab) 10 | 11 | let rec string_of_value (v: value) : string = 12 | match v with 13 | | Number n -> string_of_int n 14 | | Boolean b -> if b then "true" else "false" 15 | | Pair (v1, v2) -> 16 | Printf.sprintf "(pair %s %s)" (string_of_value v1) (string_of_value v2) 17 | | Function _ -> 18 | "" 19 | 20 | let input_channel = ref stdin 21 | let output_channel = ref stdout 22 | 23 | let rec interp_exp (defns : defn list) (env : value symtab) (exp: expr): value = 24 | match exp with 25 | | Num n -> 26 | Number n 27 | | True -> 28 | Boolean true 29 | | False -> 30 | Boolean false 31 | | Call (f, args) -> ( 32 | let vals = List.map (interp_exp defns env) args in 33 | let fv = interp_exp defns env f in 34 | match fv with 35 | | Function (name, saved_env) when is_defn defns name -> 36 | let defn = get_defn defns name in 37 | if List.length args = List.length defn.args then 38 | let fenv = (List.combine defn.args vals) |> Symtab.add_list saved_env in 39 | interp_exp defns fenv defn.body 40 | else raise (BadExpression exp) 41 | | _ -> raise (BadExpression exp) 42 | ) 43 | | Prim2 (Pair, e1, e2) -> 44 | let l = interp_exp defns env e1 in 45 | let r = interp_exp defns env e2 in 46 | Pair (l, r) 47 | | Do exps -> 48 | exps |> List.rev_map (interp_exp defns env) |> List.hd 49 | | Prim1 (Print, e) -> 50 | interp_exp defns env e |> string_of_value |> output_string !output_channel ; 51 | Boolean true 52 | | Prim0 Newline -> 53 | output_string !output_channel "\n"; 54 | Boolean true 55 | | Prim0 ReadNum -> 56 | Number (input_line !input_channel |> int_of_string) 57 | | Prim1 (Left, e) -> ( 58 | match interp_exp defns env e with 59 | | Pair (v, _) -> v 60 | | _ -> raise (BadExpression exp) 61 | ) 62 | | Prim1 (Right, e) -> ( 63 | match interp_exp defns env e with 64 | | Pair (_, v) -> v 65 | | _ -> raise (BadExpression exp) 66 | ) 67 | | Var var when Symtab.mem var env -> 68 | Symtab.find var env 69 | | Var var when is_defn defns var -> 70 | Function (var, Symtab.empty) 71 | | Var _ -> raise (BadExpression exp) 72 | | Closure f -> 73 | Function (f, env) 74 | | Let (var, e, body) -> 75 | let e_value = interp_exp defns env e in 76 | interp_exp defns (Symtab.add var e_value env) body 77 | | Prim1 (Add1, arg) as e -> ( 78 | match interp_exp defns env arg with 79 | | Number n -> Number (n + 1) 80 | | _ -> raise (BadExpression e) 81 | ) 82 | | Prim1 (Sub1, arg) as e -> ( 83 | match interp_exp defns env arg with 84 | | Number n -> Number (n - 1) 85 | | _ -> raise (BadExpression e) 86 | ) 87 | | Prim1 (Not, arg) -> 88 | if interp_exp defns env arg = Boolean false then Boolean true else Boolean false 89 | | Prim1 (ZeroP, arg) -> 90 | if interp_exp defns env arg = (Number 0) then Boolean true else Boolean false 91 | | Prim1 (NumP, arg) -> ( 92 | match interp_exp defns env arg with 93 | | Number _ -> Boolean true 94 | | _ -> Boolean false 95 | ) 96 | | Prim2 (Plus, e1, e2) -> ( 97 | match (interp_exp defns env e1, interp_exp defns env e2) with 98 | | Number n1, Number n2 -> Number (n1 + n2) 99 | | _ -> raise (BadExpression exp) 100 | ) 101 | | Prim2 (Minus, e1, e2) -> ( 102 | match (interp_exp defns env e1, interp_exp defns env e2) with 103 | | Number n1, Number n2 -> Number (n1 - n2) 104 | | _ -> raise (BadExpression exp) 105 | ) 106 | | Prim2 (Eq, e1, e2) -> ( 107 | match (interp_exp defns env e1, interp_exp defns env e2) with 108 | | Number n1, Number n2 -> Boolean (n1 = n2) 109 | | _ -> raise (BadExpression exp) 110 | ) 111 | | Prim2 (Lt, e1, e2) -> ( 112 | match (interp_exp defns env e1, interp_exp defns env e2) with 113 | | Number n1, Number n2 -> Boolean (n1 < n2) 114 | | _ -> raise (BadExpression exp) 115 | ) 116 | | If (test_exp, then_exp, else_exp) -> 117 | if interp_exp defns env test_exp = Boolean false then interp_exp defns env else_exp else interp_exp defns env then_exp 118 | 119 | let interp (program: string) : unit = 120 | let prog = parse_many program |> program_of_s_exps in 121 | interp_exp prog.defns Symtab.empty prog.body |> ignore 122 | 123 | let interp_io (program : string) (input : string) = 124 | let input_pipe_ex, input_pipe_en = Unix.pipe () in 125 | let output_pipe_ex, output_pipe_en = Unix.pipe () in 126 | input_channel := Unix.in_channel_of_descr input_pipe_ex ; 127 | set_binary_mode_in !input_channel false ; 128 | output_channel := Unix.out_channel_of_descr output_pipe_en ; 129 | set_binary_mode_out !output_channel false ; 130 | let write_input_channel = Unix.out_channel_of_descr input_pipe_en in 131 | set_binary_mode_out write_input_channel false ; 132 | let read_output_channel = Unix.in_channel_of_descr output_pipe_ex in 133 | set_binary_mode_in read_output_channel false ; 134 | output_string write_input_channel input ; 135 | close_out write_input_channel ; 136 | interp program ; 137 | close_out !output_channel ; 138 | let r = input_all read_output_channel in 139 | input_channel := stdin ; 140 | output_channel := stdout ; 141 | r 142 | 143 | let interp_err (program : string) (input : string) : string = 144 | try interp_io program input with BadExpression _ -> "ERROR" -------------------------------------------------------------------------------- /lib/util.ml: -------------------------------------------------------------------------------- 1 | 2 | let gensym : string -> string = 3 | let counter = ref 0 in 4 | fun s -> 5 | let symbol = Printf.sprintf "%s__%d" s !counter in 6 | counter := !counter + 1 ; 7 | symbol 8 | 9 | module ST = Map.Make (struct 10 | type t = string 11 | 12 | let compare = compare 13 | end) 14 | 15 | module Symtab = struct 16 | include ST 17 | 18 | let of_list l = l |> List.to_seq |> of_seq 19 | 20 | let add_list tab l = List.fold_left (fun tab (k, v) -> add k v tab) tab l 21 | 22 | end 23 | 24 | type 'a symtab = 'a Symtab.t 25 | 26 | let rec input_all (ch : in_channel) : string = 27 | try 28 | let c = input_char ch in 29 | String.make 1 c ^ input_all ch 30 | with End_of_file -> "" 31 | 32 | let defn_label s = 33 | let nasm_char c = 34 | match c with 35 | | 'a' .. 'z' 36 | | 'A' .. 'Z' 37 | | '0' .. '9' 38 | | '_' 39 | | '$' 40 | | '#' 41 | | '@' 42 | | '~' 43 | | '.' 44 | | '?' -> 45 | c 46 | | _ -> 47 | '_' 48 | in 49 | Printf.sprintf "function_%s_%d" (String.map nasm_char s) (Hashtbl.hash s) -------------------------------------------------------------------------------- /opt1.lisp: -------------------------------------------------------------------------------- 1 | (define (f x) 2 | (+ x 2)) 3 | (print (* (f (read-num)) (f (read-num)))) 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | (define (g x) 22 | (* x 3)) 23 | (define (f x) 24 | (+ (g x) 2)) 25 | (print (* (f (read-num)) (f (read-num)))) 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | (define (map f l) 45 | (if (empty? l) ()) 46 | (pair (f (left l)) (map f (right l)))) 47 | (define (f x) 48 | (+ (g x) 2)) 49 | (print (map f (pair 1 (pair 2 ())))) -------------------------------------------------------------------------------- /opt2.lisp: -------------------------------------------------------------------------------- 1 | (let ((x (read-num))) 2 | (+ (* (+ x 2) (+ x 2)) (+ x 2))) 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | (define (sum-to x) 19 | (if (= x 0) 0 20 | (+ x (sum-to (sub1 x))))) 21 | (let ((x (read-num))) 22 | (+ (* (sum-to x) (sum-to x)) (sum-to x))) 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | (define (read-plus x) 38 | (+ (read-num) x)) 39 | (let ((x (read-num))) 40 | (+ (* (read-plus x) (read-plus x)) (read-plus x))) -------------------------------------------------------------------------------- /runtime.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #define num_shift 2 6 | #define num_mask 0b11 7 | #define num_tag 0b00 8 | 9 | #define bool_shift 7 10 | #define bool_mask 0b1111111 11 | #define bool_tag 0b0011111 12 | 13 | #define heap_mask 0b111 14 | #define pair_tag 0b10 15 | #define fn_tag 0b110 16 | 17 | extern uint64_t entry(void *heap); 18 | 19 | void print_value(uint64_t value){ 20 | if ((value & num_mask) == num_tag) { 21 | int64_t ivalue = (int64_t)value; 22 | printf("%" PRIi64, ivalue >> num_shift); 23 | } else if ((value & bool_mask) == bool_tag){ 24 | if (value >> bool_shift){ 25 | printf("true"); 26 | } 27 | else{ 28 | printf("false"); 29 | } 30 | } else if ((value & heap_mask) == pair_tag){ 31 | uint64_t v1 = *(uint64_t *)(value - pair_tag); 32 | uint64_t v2 = *(uint64_t *)(value - pair_tag + 8); 33 | printf("(pair "); 34 | print_value(v1); 35 | printf(" "); 36 | print_value(v2); 37 | printf(")"); 38 | } else if ((value & heap_mask) == fn_tag){ 39 | printf(""); 40 | } 41 | else { 42 | printf("BAD VALE %" PRIu64, value); 43 | } 44 | } 45 | 46 | void error(){ 47 | printf("ERROR"); 48 | exit(1); 49 | } 50 | 51 | uint64_t read_num() { 52 | int r; 53 | scanf("%d", &r); 54 | return (uint64_t)(r) << num_shift; 55 | } 56 | 57 | void print_newline() { 58 | printf("\n"); 59 | } 60 | 61 | int main(int argc, char **argv) { 62 | void *heap = (void *)malloc(4096); 63 | entry(heap); 64 | return 0; 65 | } -------------------------------------------------------------------------------- /s_exp/dune: -------------------------------------------------------------------------------- 1 | (ocamllex 2 | (modules lex)) 3 | 4 | (menhir 5 | (modules parse)) 6 | 7 | (library 8 | (name s_exp) 9 | (preprocess 10 | (pps ppx_deriving.show))) 11 | -------------------------------------------------------------------------------- /s_exp/exp.ml: -------------------------------------------------------------------------------- 1 | type t = Num of int | Sym of string | Lst of t list [@@deriving show] 2 | -------------------------------------------------------------------------------- /s_exp/lex.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parse 3 | 4 | exception Error of string 5 | } 6 | 7 | 8 | rule token = parse 9 | | [' ' '\t' '\n'] (* also ignore newlines, not only whitespace and tabs *) 10 | { token lexbuf } 11 | | '(' 12 | { LPAREN } 13 | | ')' 14 | { RPAREN } 15 | | '-' ? ['0'-'9']+ as i 16 | { NUMBER (int_of_string i) } 17 | | ['a'-'z' 'A'-'Z' '+' '-' '*' '<' '=' '/' '>' '?']+['a'-'z' 'A'-'Z' '+' '-' '*' '<' '=' '/' '>' '?' '0'-'9']* as s 18 | { SYMBOL s } 19 | | eof 20 | { EOF } 21 | | _ 22 | { raise (Error (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) } 23 | -------------------------------------------------------------------------------- /s_exp/parse.mly: -------------------------------------------------------------------------------- 1 | %{ open Exp %} 2 | 3 | %token NUMBER 4 | %token SYMBOL 5 | %token LPAREN RPAREN 6 | %token EOF 7 | 8 | %type many 9 | %type main 10 | %start main many 11 | 12 | %% 13 | 14 | main: 15 | | e = expr EOF 16 | { e } 17 | 18 | many: 19 | | EOF 20 | { [] } 21 | | e = expr l = many 22 | { e :: l } 23 | 24 | expr: 25 | | n = NUMBER 26 | { Num n } 27 | | s = SYMBOL 28 | { Sym s } 29 | | LPAREN l=lst RPAREN 30 | { Lst l } 31 | 32 | lst: 33 | | { [] } 34 | | e = expr l = lst 35 | { e ::l } 36 | -------------------------------------------------------------------------------- /s_exp/parser.ml: -------------------------------------------------------------------------------- 1 | open Stdlib 2 | 3 | let parse (s : string) = 4 | let buf = Lexing.from_string s in 5 | Parse.main Lex.token buf 6 | 7 | let parse_file file = 8 | let inx = open_in file in 9 | let lexbuf = Lexing.from_channel inx in 10 | Parse.main Lex.token lexbuf 11 | 12 | let parse_many (s : string) = 13 | let buf = Lexing.from_string s in 14 | Parse.many Lex.token buf 15 | 16 | let parse_many_file file = 17 | let inx = open_in file in 18 | let lexbuf = Lexing.from_channel inx in 19 | Parse.many Lex.token lexbuf 20 | -------------------------------------------------------------------------------- /s_exp/s_exp.ml: -------------------------------------------------------------------------------- 1 | type s_exp = Exp.t = Num of int | Sym of string | Lst of s_exp list 2 | 3 | let show = Exp.show 4 | 5 | let parse = Parser.parse 6 | 7 | let parse_many = Parser.parse_many 8 | 9 | exception BadSExpression of s_exp --------------------------------------------------------------------------------