From 1aa704fa494f01d5f718a247b5153bbc8ec65704 Mon Sep 17 00:00:00 2001 From: tali Date: Wed, 6 Dec 2023 22:25:27 -0500 Subject: [PATCH] add back bcc with support for simple functions --- bin/main.ml | 2 +- lib/compile/bcc.ml | 192 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 190 insertions(+), 4 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 857dae1..187b576 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -5,7 +5,7 @@ let () = Logs.set_level (Some Logs.Debug); try - let ast = parse "val x = min(4, 7) println(min(x, 2))" in + let ast = parse "fun f() g() + 1 fun g() 5 println(f())" in Logs.debug (fun m -> m "%a" Ast.pp_modl ast); let prog = compile ast in Logs.debug (fun m -> m "%a" Code.pp_program prog); diff --git a/lib/compile/bcc.ml b/lib/compile/bcc.ml index 2149b71..c4e2b55 100644 --- a/lib/compile/bcc.ml +++ b/lib/compile/bcc.ml @@ -1,9 +1,195 @@ module Ast = Spice_syntax.Ast module Code = Spice_runtime.Code +module Value = Spice_runtime.Value + +exception Error of string + +let compile_error f = + Fmt.kstr (fun msg -> raise (Error msg)) f + +let off (Code.R i) k = Code.R (i + k) +let suc r = off r 1 + +module Env = struct + type t = + | Empty (* TODO: remove me *) + | Cons of t * t + | Obj of { self : Code.reg; + elems : (string, Value.elem) Hashtbl.t } + + let rec find name = function + | Empty -> raise Not_found + | Cons (e1, e2) -> + begin + try find name e2 + with Not_found -> find name e1 + end + | Obj { self; elems } -> + self, Hashtbl.find elems name +end let compile modl lib = - let _ : Ast.modl = modl in - let _ = lib in - let ep = Code.make_block () in + let currb = ref ep in + let emit i = Code.extend !currb i in + let enter b = currb := b in + + let rec compile_exp env rd = function + | Ast.Literal (Int n) -> emit (LDI (rd, Int n)) + | Ast.Literal True -> emit (LDI (rd, True)) + | Ast.Literal False -> emit (LDI (rd, False)) + | Ast.Literal Nil -> emit (LDI (rd, Nil)) + + | Ast.Path path -> + let obj, loc = compile_path env rd path in + emit (GET (rd, obj, loc)) + + | Ast.Binop (op, e1, e2) -> + let r1 = rd in + let r2 = suc rd in + compile_exp env r1 e1; + compile_exp env r2 e2; + begin match op with + | Ast.Add -> emit (ADD (rd, r1, r2)) + | Ast.Sub -> emit (ADD (rd, r1, r2)) + | Ast.Mul -> emit (ADD (rd, r1, r2)) + | Ast.Div | Ast.Mod -> failwith "Bcc.compile_exp: TODO(Div,Mod)" + | Ast.Eql -> emit (EQL (rd, r1, r2)) + | Ast.Grt -> emit (GRT (rd, r1, r2)) + | Ast.Lst -> emit (LST (rd, r1, r2)) + | Ast.Not_eql -> emit (EQL (r1, r1, r2)); emit (NOT (rd, r1)) + | Ast.Lst_eql -> emit (GRT (r1, r1, r2)); emit (NOT (rd, r1)) + | Ast.Grt_eql -> emit (LST (r1, r1, r2)); emit (NOT (rd, r1)) + end + + | Ast.Call (fn, args) -> + let obj, mth = compile_path env rd fn in + let args = + List.mapi + (fun i arg -> + let ri = off mth (i + 1) in + compile_exp env ri arg; + ri) + args + in + emit (CAL (rd, obj, mth, args)) + + | Ast.If (e0, e1, e2) -> + let r0 = rd in + compile_exp env r0 e0; + let b1 = Code.make_block () in + let b2 = Code.make_block () in + emit (CBR (r0, b1, b2)); + let jp = Code.make_block () in + enter b1; compile_exp env rd e1; emit (JMP jp); + enter b2; compile_exp env rd e2; emit (JMP jp); + enter jp + + | Ast.Fun (_, _) -> + failwith "Bcc.compile_exp: TODO(Fun)" + + | Ast.Obj items -> + ignore (compile_block env rd items) + + | Ast.Scope items -> + begin match compile_block env rd items with + | Some r -> emit (LDR (rd, r)) + | None -> compile_error "scope does not end with an expression" + end + + and compile_path env rd path = + match path with + | Ast.Var name -> + let obj, ele = + try Env.find name env + with Not_found -> + compile_error "unbound variable %S" name + in + let loc = rd in + emit (LDI (loc, Value.of_elem ele)); + obj, loc + | Ast.Ele (lhs, name) -> + let obj = rd in + let loc = suc rd in + compile_exp env obj lhs; + emit (LOC (loc, obj, name)); + obj, loc + + and compile_block env rd items = + let elems = Hashtbl.create 100 in + let n_vals, _, funs_rev = + List.fold_left + (fun (nv, nf, fns) -> function + | Ast.Item_exp _ -> nv, nf, fns + | Ast.Item_val (name, _) + | Ast.Item_obj (name, _) -> + Hashtbl.add elems name (Value.Field nv); + nv + 1, nf, fns + | Ast.Item_fun (name, params, body) -> + Hashtbl.add elems name (Value.Method nf); + nv, nf + 1, (name, params, body) :: fns) + (0, 0, []) + items + in + + let prevb = !currb in + let mthds = + let clo = Code.R 0 in + let env = Env.Obj { self = clo; elems } in + List.rev_map + (fun (_, params, body) -> + if params <> [] then + failwith "Bcc.compile_block: TODO(params)"; + let ep = Code.make_block () in + enter ep; + let rv = Code.R 1 in + compile_exp env rv body; + emit (RET rv); + Code.Method { n_args = 0; body = { Code.entry = ep } }) + funs_rev + |> Array.of_list + in + + enter prevb; + emit (CON (rd, { n_slots = n_vals; elems; mthds })); + + let r0 = suc rd in + let r1 = suc r0 in + let env = Env.Cons (env, Env.Obj { self = rd; elems }) in + List.fold_left + (fun _ -> function + | Ast.Item_exp exp -> + compile_exp env r0 exp; + Some r0 + | Ast.Item_val (name, exp) -> + let el = Hashtbl.find elems name in + emit (LDI (r0, Value.of_elem el)); + compile_exp env r1 exp; + emit (SET (r1, rd, r0)); + None + | Ast.Item_obj (name, body) -> + (* TODO: it would be ideal if we could CONstruct the empty versions of obj's in + a sort of "pre-init" phase, before assigning field values. but for now, obj + items are identical to val's where the rhs is an obj expression. *) + let el = Hashtbl.find elems name in + emit (LDI (r0, Value.of_elem el)); + compile_block env r1 body |> ignore; + emit (SET (r1, rd, r0)); + None + | Ast.Item_fun (_, _, _) -> + (* already handled previously *) + None) + None + items + in + + let init_env = + let elems = Hashtbl.create 100 in + List.iteri (fun i (name, _) -> Hashtbl.add elems name (Value.Method i)) lib; + Env.Obj { self = R 0; elems } + in + let rv = Code.R 1 in + compile_block init_env rv modl.Ast.items |> ignore; + emit (RET rv); + { Code.entry = ep }