diff --git a/lib/compiler/core_ast.ml b/lib/compiler/core_ast.ml index ae65db6..d3af0dd 100644 --- a/lib/compiler/core_ast.ml +++ b/lib/compiler/core_ast.ml @@ -17,8 +17,8 @@ type literal = type expression = | Literal of literal | Var of string - | Apply of expression * expression - | Lambda of string * expression + | Apply of expression * expression list + | Lambda of string list * string option * expression | If of expression * expression * expression | Set of string * expression | Begin of expression list @@ -35,42 +35,30 @@ let rec pair_of_def : Syntactic_ast.def -> string * expression = and pair_of_binding (s, e) = (s, of_expr e) and pair_of_clause (e1, e2) = (of_expr e1, of_expr e2) -and make_lambda args body = - match args with - (* TODO: gensym here instead of using _ directly *) - | [] -> Lambda ("_", of_body body) - | x :: [] -> Lambda (x, of_body body) - | x :: xs -> Lambda (x, make_lambda xs body) - -and make_apply f args = - let rec aux f = function - | [] -> Apply (f, Literal Nil) - | arg :: [] -> Apply (f, arg) - | arg :: args -> aux (Apply (f, arg)) args - in aux f args +and make_lambda (args, rest) body = + Lambda (args, rest, body) (* desugars this... (let ((x 5) (y 4)) (f x y)) ... into this... - (((lambda (x) (lambda (y) ((f x) y))) 5) 4) + ((lambda (x y) (f x y)) 5 4) *) and make_let bs body = let bs = List.map pair_of_binding bs in - let rec aux = function - | (s, e) :: rest -> - Apply (Lambda (s, aux rest), e) - | [] -> of_body body in - aux bs + let args = List.map (fun (s, _) -> s) bs in + let es = List.map (fun (_, e) -> e) bs in + Apply (Lambda (args, None, body), es) (* The Core AST does not feature a letrec node. Instead, we desugar letrecs further into a let that binds each symbol to nil, then `set!`s them to their real value before running the body. *) and make_letrec bs exprs = - let tmp_bs = List.map (fun (s, _) -> (s, Literal Nil)) bs in + let tmp_bs = List.map (fun (_, _) -> Literal Nil) bs in let setters = List.fold_right (fun (s, e) acc -> (Set (s, e)) :: acc) bs [] in + let args = List.map (fun (s, _) -> s) bs in let body = Begin ((List.rev setters) @ exprs) in - List.fold_right (fun (s, e) acc -> Apply (Lambda (s, acc), e)) tmp_bs body + Apply (Lambda (args, None, body), tmp_bs) (* We convert a body into a regular letrec form. A body is defined as a series of definitions followed by a series @@ -86,10 +74,8 @@ and of_body : Syntactic_ast.body -> expression = function let defs = List.map pair_of_def defs in make_letrec defs exprs -(* TODO: currently this ignores the "optional" part of the lambda list, - fix this *) -and of_ll : Syntactic_ast.lambda_list -> string list = function - | (sl, _) -> sl +and of_ll : Syntactic_ast.lambda_list -> string list * string option = function + | (sl, rest) -> (sl, rest) and of_literal : Syntactic_ast.literal -> literal = function | LitInt x -> Int x @@ -102,8 +88,8 @@ and of_literal : Syntactic_ast.literal -> literal = function and of_expr : Syntactic_ast.expr -> expression = function | Literal l -> Literal (of_literal l) | Var x -> Var x - | Lambda (ll, b) -> make_lambda (of_ll ll) b - | Let (bindings, b) -> make_let bindings b + | Lambda ((args, rest), b) -> Lambda (args, rest, of_body b) + | Let (bindings, b) -> make_let bindings (of_body b) | LetRec (bindings, b) -> make_letrec (List.map pair_of_binding bindings) [(of_body b)] | Cond (clauses) -> List.fold_right @@ -113,7 +99,7 @@ and of_expr : Syntactic_ast.expr -> expression = function | If (e1, e2, e3) -> If (of_expr e1, of_expr e2, of_expr e3) | Set (s, e) -> Set (s, of_expr e) - | Apply (f, es) -> make_apply (of_expr f) (List.map of_expr es) + | Apply (f, es) -> Apply (of_expr f, List.map of_expr es) and of_syntactic : Syntactic_ast.top_level -> top_level = function diff --git a/lib/compiler/emit.ml b/lib/compiler/emit.ml index 5a612c7..7bcdaea 100644 --- a/lib/compiler/emit.ml +++ b/lib/compiler/emit.ml @@ -7,7 +7,7 @@ type instr = Vm.Types.instr type pre_instr = | Instr of instr - | BackPatchMkClosure + | BackPatchMkClosure of int | BackPatchJumpF type program = { @@ -27,8 +27,8 @@ let current_index p = let set_instr p i ins = Dynarray.set p.instrs i (Instr ins) -let emit_mkclosure p = - Ok (Dynarray.add_last p.instrs BackPatchMkClosure) +let emit_mkclosure p i = + Ok (Dynarray.add_last p.instrs (BackPatchMkClosure i)) let emit_jumpf p = Ok (Dynarray.add_last p.instrs BackPatchJumpF) @@ -62,12 +62,12 @@ let rec compile_one p = function | Set (Global i, expr) -> let* _ = compile_one p expr in emit_instr p (Vm.Types.StoreGlobal i) - | Apply (f, arg) -> + | Apply (f, args) -> let* _ = compile_one p f in - let* _ = compile_one p arg in - emit_instr p Vm.Types.Apply - | Lambda body -> - let* _ = emit_mkclosure p in + let* _ = compile_all_no_pop p args in + emit_instr p (Vm.Types.Apply (List.length args)) + | Lambda (arg_count, body) -> + let* _ = emit_mkclosure p arg_count in Ok (Queue.push ((Dynarray.length p.instrs) - 1, body) p.backpatch) | If (test, t, f) -> (* *) @@ -99,6 +99,10 @@ and compile_all p exprs = (fun e -> let* _ = compile_one p e in emit_instr p Pop) exprs +and compile_all_no_pop p exprs = + Util.traverse + (fun e -> + let* _ = compile_one p e in Ok ()) exprs (* Once we have compiled the top-level expressions, we must now compile all of the lambdas we held off on. Some of these will hold more @@ -106,9 +110,12 @@ and compile_all p exprs = of the backpatch queue. *) let backpatch_one p (i, b) = - Dynarray.set p.instrs i (Instr (MakeClosure (current_index p))); - let* _ = compile_one p b in - emit_instr p End + match Dynarray.get p.instrs i with + | BackPatchMkClosure arg_count -> + Dynarray.set p.instrs i (Instr (MakeClosure (arg_count, current_index p))); + let* _ = compile_one p b in + emit_instr p End + | _ -> failwith "Can't backpatch anything other than a MakeClosure after compilation" let rec backpatch p = if Queue.is_empty p.backpatch then Ok () @@ -120,7 +127,7 @@ let rec backpatch p = let print_instr = function | Instr i -> Vm.Types.print_one i | BackPatchJumpF -> "BACKPATCH JUMPF\n" - | BackPatchMkClosure -> "BACKPATCH CLOSURE\n" + | BackPatchMkClosure i -> "BACKPATCH CLOSURE \n" ^ (string_of_int i) let print_instrs = Array.mapi_inplace (fun i ins -> print_endline (Printf.sprintf "%d: %s" i (print_instr ins)); ins) diff --git a/lib/compiler/scope_analysis.ml b/lib/compiler/scope_analysis.ml index b30ea5c..7217dcd 100644 --- a/lib/compiler/scope_analysis.ml +++ b/lib/compiler/scope_analysis.ml @@ -33,8 +33,8 @@ type variable = type expression = | Literal of literal | Var of variable - | Apply of expression * expression - | Lambda of expression + | Apply of expression * expression list + | Lambda of int * expression | If of expression * expression * expression | Set of variable * expression | Begin of expression list @@ -93,11 +93,13 @@ let resolve_global tbl sym = global table if we can't find it in the local environment *) let resolve_symbol tbl env sym = - let rec aux counter = function + let rec aux counter env_num = function | [] -> resolve_global tbl sym - | x :: _ when String.equal x sym -> Ok (Local counter) - | _ :: rest -> aux (counter + 1) rest - in aux 0 env + | x :: rest -> + match List.find_index (String.equal sym) x with + | Some i -> Ok (Local (counter + i)) + | None -> aux (counter + (List.length (x :: rest))) (env_num + 1) rest + in aux 0 0 env let resolve_var tbl env sym = let* sym = resolve_symbol tbl env sym in @@ -106,6 +108,16 @@ let resolve_var tbl env sym = let resolve_set tbl env sym expr = let* sym = resolve_symbol tbl env sym in Ok (Set (sym, expr)) + +let extract_function = function + | Core_ast.Define (s, Core_ast.Lambda (args, rest, _)) -> Some (s, args, rest) + | _ -> None + +let extract_functions exprs = + let fs = List.filter Option.is_some (List.map extract_function exprs) in + let fs = List.map Option.get fs in + List.fold_left (fun t (s, args, rest) -> SymbolTable.add s (args, rest) t) SymbolTable.empty fs + (* We need to do some more sophisticated analysis to detect cases where a symbol is accessed before it is defined. If a symbol is accessed in a lambda body, that is fine, since that computation @@ -133,12 +145,15 @@ let convert program = | Set (sym, expr) -> let* inner = analyze tbl current expr in resolve_set tbl current sym inner - | Lambda (s, body) -> - let* body = (analyze global_tbl (s :: current) body) in - Ok (Lambda body) - | Apply (f, e) -> + | Lambda (args, rest, body) -> + let args = (match rest with + | Some s -> List.append args [s] + | None -> args) in + let* body = (analyze global_tbl (args :: current) body) in + Ok (Lambda (List.length args, body)) + | Apply (f, es) -> let* f = analyze tbl current f in - let* e = analyze tbl current e in + let* e = Util.traverse (analyze tbl current) es in Ok (Apply (f, e)) | If (test, pos, neg) -> let* test = analyze tbl current test in diff --git a/lib/compiler/syntactic_ast.ml b/lib/compiler/syntactic_ast.ml index 970c09e..30e0a45 100644 --- a/lib/compiler/syntactic_ast.ml +++ b/lib/compiler/syntactic_ast.ml @@ -82,13 +82,14 @@ let expect_sym = function TODO: add diagnostics, e.g. what sexpr, specifically, couldn't be turned to a list? generally more debugging is needed in this module. *) -let rec list_of_sexpr = function +let rec list_of_sexpr = function | LCons (i, next) -> let* next = list_of_sexpr next in Ok (i :: next) | LNil -> Ok [] | _ -> Error "cannot transform sexpr into list, malformed sexpr!" + (* parse the argument list of a lambda form *) let parse_lambda_list cons = let rec aux acc = function diff --git a/lib/vm/native.ml b/lib/vm/native.ml index 1f53fed..d9d0832 100644 --- a/lib/vm/native.ml +++ b/lib/vm/native.ml @@ -5,8 +5,8 @@ *) open Types -let builtin_print (v : Types.value) = - print_endline (print_value v); +let builtin_print (v : Types.value ref list) = + List.iter (fun r -> print_endline (print_value !r)) v; Types.Nil let table = [| diff --git a/lib/vm/types.ml b/lib/vm/types.ml index 5559d21..a431439 100644 --- a/lib/vm/types.ml +++ b/lib/vm/types.ml @@ -6,7 +6,7 @@ type value = | Nil | Cons of value * value | Symbol of string - | Closure of int * value ref list + | Closure of int * int * value ref list | Native of int (* This is basically a syscall, each ID represents a primitive operation that should have a well-defined effect. These will be further detailed in the language documentation @@ -20,8 +20,8 @@ type instr = | StoreGlobal of int | MakeCons | Pop (* discards top of stack *) - | Apply - | MakeClosure of int + | Apply of int (* arg count *) + | MakeClosure of int * int (* arg count, code pointer *) | Jump of int | JumpF of int (* jump if false. *) | End @@ -47,7 +47,7 @@ let rec print_value = function | Nil -> p "'()" | Cons (a, b) -> p "(%s . %s)" (print_value a) (print_value b) | Symbol x -> p "'%s" x - | Closure (i, _) -> p "" i + | Closure (a, i, _) -> p "" a i | Native i -> p "" i @@ -59,8 +59,8 @@ let print_one = function | StoreGlobal i -> p "STORE_GLOBAL %d\n" i | MakeCons -> p "CONS\n" | Pop -> p "POP\n" - | Apply -> p "APPLY\n" - | MakeClosure i -> p "MKCLOSURE %d\n" i + | Apply i -> p "APPLY %d\n" i + | MakeClosure (a, i) -> p "MKCLOSURE %d, %d\n" a i | Jump i -> p "JMP %d\n" i | JumpF i -> p "JMPF %d\n" i | End -> p "END\n" diff --git a/lib/vm/vm.ml b/lib/vm/vm.ml index a58540d..e134340 100644 --- a/lib/vm/vm.ml +++ b/lib/vm/vm.ml @@ -16,6 +16,11 @@ let pop_one state = match state.stack with | v :: rest -> state.stack <- rest; v | [] -> failwith ("VM error: cannot pop from empty stack! " ) +let pop_args state count = + let rec aux acc i = + if i <= 0 then acc + else aux ((ref (pop_one state)) :: acc) (i - 1) + in aux [] count let peek_one state = match state.stack with | v :: _ -> v @@ -29,19 +34,20 @@ let trace state = let env () = List.fold_left (fun acc x -> acc ^ " " ^ (Types.print_value !x)) "" state.env in Printf.printf "%d: \n\tstack: [%s ]\n\tenv:[%s]\n" state.i (stack ()) (env ()) -let rec do_apply state = +let rec do_apply state arg_count = let cur_env = state.env in let cur_i = state.i in - let arg = pop_one state in + let args = pop_args state arg_count in let f = pop_one state in match f with - | Closure (x, e) -> + | Closure (a, _, _) when a != arg_count -> failwith "Wrong argument count to function" + | Closure (_, x, e) -> state.call_stack <- (cur_i, cur_env) :: state.call_stack; state.i <- x; - state.env <- (ref arg) :: e; + state.env <- List.append args e; interpret state | Native x -> - push state (Native.table.(x) arg); + push state (Native.table.(x) args); interpret state | _ -> failwith "Cannot apply non-closure object" @@ -60,8 +66,8 @@ and interpret state = let car = pop_one state in push state (Cons (car, cdr)) | Pop -> ignore (pop_one state) ; interpret state - | Apply -> do_apply state - | MakeClosure x -> push state (Closure (x, state.env)); interpret state + | Apply a -> do_apply state a + | MakeClosure (args, x) -> push state (Closure (args, x, state.env)); interpret state | Jump target -> state.i <- target ; interpret state | JumpF target -> (match (pop_one state) with