vm and compiler: removed automatic currying, and several other modifications to the language

lib/compiler/core_ast.ml

@@ -17,8 +17,8 @@ type literal =
 type expression =
   | Literal of literal
   | Var of string
-  | Apply of expression * expression
+  | Apply of expression * expression list
-  | Lambda of string * expression
+  | 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 =
+and make_lambda (args, rest) body =
-  match args with
+  Lambda (args, rest, body)
-    (* 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
 
 (* 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
+  let args = List.map (fun (s, _) -> s) bs in
-    | (s, e) :: rest ->
+  let es = List.map (fun (_, e) -> e) bs in
-       Apply (Lambda (s, aux rest), e)
+  Apply (Lambda (args, None, body), es)
-    | [] -> of_body body in
-  aux bs
 
 (* 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,
+and of_ll : Syntactic_ast.lambda_list -> string list * string option = function
-   fix this *)
+  | (sl, rest) -> (sl, rest)
-and of_ll : Syntactic_ast.lambda_list -> string list = function
-  | (sl, _) -> sl
 
 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
+  | Lambda ((args, rest), b) -> Lambda (args, rest, of_body b)
-  | Let (bindings, b) -> make_let bindings 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

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 =
+let emit_mkclosure p i =
-  Ok (Dynarray.add_last p.instrs BackPatchMkClosure)
+  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
+     let* _ = compile_all_no_pop p args in
-     emit_instr p Vm.Types.Apply
+     emit_instr p (Vm.Types.Apply (List.length args))
-  | Lambda body ->
+  | Lambda (arg_count, body) ->
-     let* _ = emit_mkclosure p in
+     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)));
+  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)

lib/compiler/scope_analysis.ml

@@ -33,8 +33,8 @@ type variable =
 type expression =
   | Literal of literal
   | Var of variable
-  | Apply of expression * expression
+  | Apply of expression * expression list
-  | Lambda of expression
+  | 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)
+    | x :: rest ->
-    | _ :: rest -> aux (counter + 1) rest
+       match List.find_index (String.equal sym) x with
-  in aux 0 env
+       | 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) ->
+    | Lambda (args, rest, body) ->
-       let* body = (analyze global_tbl (s :: current) body) in
+       let args = (match rest with
-       Ok (Lambda body)
+                  | Some s -> List.append args [s]
-    | Apply (f, e) ->
+                  | 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

lib/compiler/syntactic_ast.ml

@@ -89,6 +89,7 @@ let rec list_of_sexpr = function
   | 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

lib/vm/native.ml

@@ -5,8 +5,8 @@
  *)
 open Types
 
-let builtin_print (v : Types.value) =
+let builtin_print (v : Types.value ref list) =
-  print_endline (print_value v);
+  List.iter (fun r -> print_endline (print_value !r)) v;
   Types.Nil
 
 let table = [|

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
+  | Apply of int (* arg count *)
-  | MakeClosure of int
+  | 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 "<closure %d>" i
+    | Closure (a, i, _) -> p "<closure of %d args at %d>" a i
     | Native i -> p "<native %d>" 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"
+    | Apply i -> p "APPLY %d\n" i
-    | MakeClosure i -> p "MKCLOSURE %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"

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
+  | Apply a -> do_apply state a
-  | MakeClosure x -> push state (Closure (x, state.env)); interpret state
+  | 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