remove lir, add basic single pass compiler

This commit is contained in:
tali 2023-11-29 22:24:51 -05:00
parent 846cae64ff
commit c1eaa5baef
9 changed files with 106 additions and 348 deletions

View File

@ -5,38 +5,8 @@ let[@warning "-26"] () =
Logs.set_level (Some Logs.Debug);
try
let int n = Code.Cst_int (Int64.of_int n) in
let reg n = Code.Reg n in
let vtable = Value.make_vtable [ "x"; "y" ] in
let ep =
Code.make_basic_block
[
(* obj o {...} *)
CON (0, vtable);
(* o.x = 999 *)
MOV (2, int 999);
MOV (1, int 0);
SET (0, 1);
(* o.y = 11 *)
MOV (2, int 11);
MOV (1, int 1);
SET (0, 1);
(* _1 = o.x *)
MOV (1, int 0);
GET (0, 1);
(* _2 = o.y *)
MOV (2, int 1);
GET (0, 2);
(* _3 = _1 * _2 *)
MUL (2, reg 1);
(* o.x = _3 *)
MOV (1, int 0);
SET (0, 1);
]
in
let prog = Code.make_program ep in
let ast = parse "val o = obj { val x = 3 }" in
let prog = compile ast in
let ret = run prog in
Fmt.pr "{\"program\":%a,\"output\":%a}" Code.pp_program prog Value.pp ret
with Error msg -> Logs.err (fun m -> m "%s" msg)

97
lib/compile/bcc.ml Normal file
View File

@ -0,0 +1,97 @@
module Ast = Spice_syntax.Ast
module Code = Spice_runtime.Code
module Value = Spice_runtime.Value
module Env = Map.Make (String)
type binding = {
self : Code.regidx;
slot : Value.slotidx;
}
let compile modl =
let ep = Code.make_basic_block [] in
let sp = ref 0 in
let bb = ref ep in
let emit is = Code.add_ins !bb is in
let emit_mov l r = if r <> Code.Reg l then emit (MOV (l, r)) in
let rec compile_exp env = function
| Ast.Literal Nil -> Code.Cst_nil
| Ast.Literal True -> Code.Cst_true
| Ast.Literal False -> Code.Cst_false
| Ast.Literal (Int i) -> Code.Cst_int i
| Ast.Path (Var name) -> (
match Env.find name env with
| exception Not_found -> Fmt.failwith "unbound: %S" name
| { self; slot } ->
let ret = !sp in
sp := ret + 1;
emit_mov ret (Code.cst_of_int slot);
emit (GET (self, ret));
Reg ret)
| Ast.Binop (op, e1, e2) ->
let ret = !sp in
let lhs = compile_exp env e1 in
let rhs = compile_exp env e2 in
sp := ret + 1;
emit_mov ret lhs;
emit
(match op with
| Ast.Add -> ADD (ret, rhs)
| Ast.Sub -> SUB (ret, rhs)
| Ast.Mul -> MUL (ret, rhs)
| _ -> Fmt.failwith "Bcc.compile_exp: TODO: %S" (Ast.string_of_binop op));
Reg ret
| Ast.Obj body -> compile_obj env body
| _ -> failwith "Bcc.compile_exp: TODO"
and compile_obj env items =
let self = !sp in
(* construct new env and vtable *)
let elems = Hashtbl.create (List.length items * 2) in
let env, n_slots =
List.fold_left
(fun (env, n) -> function
| Ast.Item_fun (_, _, _) | Ast.Item_exp _ -> env, n
| Ast.Item_obj (name, _) | Ast.Item_val (name, _) ->
let slot = n in
let env = Env.add name { self; slot } env in
Hashtbl.add elems name (Value.Field slot);
env, n + 1)
(env, 0)
items
in
let vtable = Value.{ elems; n_slots } in
(* emit constructor / field inits *)
emit (CON (self, vtable));
let emit_set name rhs =
let slot = (Env.find name env).slot in
emit_mov (self + 2) rhs;
emit_mov (self + 1) (Code.cst_of_int slot);
emit (SET (self, self + 1))
in
List.iter
(function
| Ast.Item_fun (_, _, _) -> failwith "Bcc: unsupported: methods"
| Ast.Item_exp e ->
sp := self + 1;
ignore (compile_exp env e)
| Ast.Item_obj (name, body) ->
sp := self + 2;
emit_set name (compile_obj env body)
| Ast.Item_val (name, rhs) ->
sp := self + 2;
emit_set name (compile_exp env rhs))
items;
(* reset sp and return self *)
sp := self + 1;
Code.Reg self
in
let env = Env.empty in
emit_mov 0 (compile_obj env modl.Ast.items);
emit RET;
Code.make_program ep

3
lib/compile/dune Normal file
View File

@ -0,0 +1,3 @@
(library
(name spice_compile)
(libraries spice_runtime spice_syntax))

View File

@ -1,3 +1,3 @@
(library
(name spice)
(libraries fmt spice_syntax spice_lower spice_runtime))
(libraries fmt spice_syntax spice_runtime spice_compile))

View File

@ -1,3 +0,0 @@
(library
(name spice_lower)
(libraries spice_syntax fmt))

View File

@ -1,135 +0,0 @@
module Syn = Spice_syntax.Ast
module Id = struct
type t = {
name : string;
uid : int;
}
let to_string { name; uid } = Fmt.str "%s#%d" name uid
let compare a b = Int.compare a.uid b.uid
let hash a = a.uid
let equal a b =
if a.uid = b.uid then (
assert (String.equal a.name b.name);
true)
else false
end
type name = Syn.name
type literal = Syn.literal
type binop = Syn.binop
(* TODO: split between arithmetic operators vs comparison operators *)
type arg = Arg of Id.t [@@unboxed]
type ele = Ele of arg * name
type exp =
| Let of Id.t * rhs * exp
| Set of ele * arg * exp
| If of arg * exp * exp
| Jump of Id.t * arg list
| Ret of arg
and rhs =
| Literal of literal
| Get of ele
| Call of ele * arg list
| Binop of binop * arg * arg
| Cont of cont
| Obj of block
and block = {
slots : name list;
mthds : mthd list;
}
and mthd = {
name : string;
defn : cont;
}
and cont = {
params : Id.t list;
body : exp;
}
type entrypoint = cont
(* pretty printer *)
let pp_list pp_ele ppf list =
Fmt.pf ppf "[";
List.iteri
(fun i ele ->
if i > 0 then Fmt.pf ppf ",";
pp_ele ppf ele)
list;
Fmt.pf ppf "]"
let pp_name ppf name = Fmt.pf ppf "%S" name
let rec pp_exp ppf exp =
Fmt.pf ppf "[";
let rec loop i exp =
if i > 0 then Fmt.pf ppf ",";
match exp with
| Let (name, rhs, rest) ->
Fmt.pf ppf "{\"let\":%a%a}" pp_id name pp_rhs rhs;
loop (i + 1) rest
| Set (e, v, rest) ->
Fmt.pf ppf "{\"set\":%a,\"value\":%a}" pp_ele e pp_arg v;
loop (i + 1) rest
| If (v1, e2, e3) ->
Fmt.pf ppf "{\"if\":%a,\"then\":%a,\"else\":%a}]" pp_arg v1 pp_exp e2 pp_exp e3
| Jump (tgt, args) ->
Fmt.pf ppf "{\"jump\":%a,\"args\":%a}]" pp_id tgt (pp_list pp_arg) args
| Ret v -> Fmt.pf ppf "{\"ret\":%a}]" pp_arg v
in
loop 0 exp
and pp_id ppf id = Fmt.pf ppf "%S" (Id.to_string id)
and pp_arg ppf = function
| Arg id -> pp_id ppf id
and pp_ele ppf = function
| Ele (Arg ob, el) -> Fmt.pf ppf "\"%s.%s\"" (Id.to_string ob) el
and pp_rhs ppf = function
| Literal (Int n) -> Fmt.pf ppf ",\"int\":%s" (Int64.to_string n)
| Literal l -> Fmt.pf ppf ",\"lit\":%S" (Syn.string_of_literal l)
| Get e -> Fmt.pf ppf ",\"get\":%a" pp_ele e
| Call (fn, args) ->
Fmt.pf ppf ",\"call\":%a,\"args\":%a" pp_ele fn (pp_list pp_arg) args
| Binop (op, v1, v2) ->
Fmt.pf
ppf
",\"binop\":%S,\"lhs\":%a,\"rhs\":%a"
(Syn.string_of_binop op)
pp_arg
v1
pp_arg
v2
| Cont { params; body } ->
Fmt.pf ppf ",\"cont\":%a,\"body\":%a" (pp_list pp_id) params pp_exp body
| Obj { slots; mthds } ->
Fmt.pf ppf ",\"obj\":{\"slots\":%a,\"mthds\":{" (pp_list pp_name) slots;
List.iteri
(fun i { name; defn = { params; body } } ->
if i > 0 then Fmt.pf ppf ",";
Fmt.pf
ppf
"%S:{\"params\":%a,\"body\":%a}"
name
(pp_list pp_id)
params
pp_exp
body)
mthds;
Fmt.pf ppf "}}"
let pp_entrypoint ppf { params; body } =
Fmt.pf ppf "{\"inputs\":%a,\"program\":%a}" (pp_list pp_id) params pp_exp body

View File

@ -1,173 +0,0 @@
module Env = Map.Make (String)
module Syn = Spice_syntax.Ast
type binding =
| Var_arg of Lir.arg
| Var_ele of Lir.arg * Lir.name
| Var_fun of Lir.arg * Lir.name
let ( @@@ ) f g x = f (g x)
let fcf_mthd_name = "call"
let to_anf modl =
let next_uid = ref 0 in
let gen_id name =
let uid = !next_uid in
incr next_uid;
Lir.Id.{ name; uid }
in
let lift_rhs name rhs =
let tmp = gen_id name in
let ctx rest = Lir.Let (tmp, rhs, rest) in
Lir.Arg tmp, ctx
in
let rec lower_exp env = function
| Syn.Literal l -> lift_rhs "lit" (Lir.Literal l)
| Syn.Path p -> lower_path env p
| Syn.Call (fn, args) ->
let (ob_v, ob_ctx), mthd =
match fn with
| Syn.Ele (ob, mthd) -> lower_exp env ob, mthd
| Syn.Var f -> (
match Env.find f env with
| Var_fun (ob, mthd) -> (ob, Fun.id), mthd
| _ -> lower_path env fn, fcf_mthd_name)
in
let arg_vs_rev, ctx =
List.fold_left
(fun (vs, ctx) arg ->
let v, v_ctx = lower_exp env arg in
v :: vs, ctx @@@ v_ctx)
([], ob_ctx)
args
in
let fn_e = Lir.Ele (ob_v, mthd) in
let arg_vs = List.rev arg_vs_rev in
let v, call_ctx = lift_rhs mthd (Lir.Call (fn_e, arg_vs)) in
v, ctx @@@ call_ctx
| Syn.Binop (op, e1, e2) ->
let v1, v1_ctx = lower_exp env e1 in
let v2, v2_ctx = lower_exp env e2 in
let v, op_ctx = lift_rhs "op" (Lir.Binop (op, v1, v2)) in
v, v1_ctx @@@ v2_ctx @@@ op_ctx
| Syn.If (e1, e2, e3) ->
let v1, v1_ctx = lower_exp env e1 in
let v2, v2_ctx = lower_exp env e2 in
let v3, v3_ctx = lower_exp env e3 in
let jn = gen_id "jn" in
let rv = gen_id "rv" in
let ctx rest =
let cont = Lir.{ params = [ rv ]; body = rest } in
let e2 = v2_ctx (Lir.Jump (jn, [ v2 ])) in
let e3 = v3_ctx (Lir.Jump (jn, [ v3 ])) in
v1_ctx (Lir.Let (jn, Cont cont, If (v1, e2, e3)))
in
Lir.Arg rv, ctx
| Syn.Obj items -> lower_obj env items
(* | Syn.Fun (xs, e) -> () *)
(* | Syn.Scope items -> () *)
| _ -> failwith "..."
and lower_path env = function
| Syn.Var x -> (
match Env.find x env with
| Var_arg v -> v, Fun.id
| Var_ele (ob, el) -> lift_rhs x (Lir.Get (Ele (ob, el)))
| Var_fun (ob, el) ->
(* TODO: special treatment for known FCF's? *)
lift_rhs x (Lir.Get (Ele (ob, el)))
| exception Not_found -> failwith (Fmt.str "undefined variable %S" x))
| Syn.Ele (ob, el) ->
let ob_v, ob_ctx = lower_exp env ob in
let el_v, el_ctx = lift_rhs el (Lir.Get (Ele (ob_v, el))) in
el_v, ob_ctx @@@ el_ctx
and lower_obj env items =
(* TODO: detect duplicate item names *)
let ob = gen_id "ob" in
let ob_v = Lir.Arg ob in
(* TODO: get last expression in block *)
let env, slots, mthds, inits =
List.fold_left
(fun (env, slots, mthds, inits) -> function
| Syn.Item_exp e ->
let inits = `Exp e :: inits in
env, slots, mthds, inits
| Syn.Item_val (name, rhs) ->
let env = Env.add name (Var_ele (ob_v, name)) env in
let slots = name :: slots in
let inits = `Val (name, rhs) :: inits in
env, slots, mthds, inits
| Syn.Item_obj (name, body) ->
let env = Env.add name (Var_ele (ob_v, name)) env in
let slots = name :: slots in
let inits = `Obj (name, body) :: inits in
env, slots, mthds, inits
| Syn.Item_fun (name, param_names, body) ->
let env = Env.add name (Var_fun (ob_v, name)) env in
let mthds = (name, param_names, body) :: mthds in
env, slots, mthds, inits)
(env, [], [], [])
items
in
(* mthds was built in reverse order, so rev_map fixes the order *)
let mthds =
List.rev_map
(fun (name, param_names, body) ->
(* TODO: detect duplicate param names *)
let params = List.map gen_id param_names in
let env' =
List.fold_left2
(fun env name id -> Env.add name (Var_arg (Arg id)) env)
env
param_names
params
in
let body_v, body_ctx = lower_exp env' body in
let body = body_ctx (Lir.Ret body_v) in
Lir.{ name; defn = { params; body } })
mthds
in
(* inits was built in reverse order, so make sure to *prepend* contexts
* when building the final context *)
let init_ctx =
List.fold_left
(fun ctx' -> function
| `Exp e ->
let _, ctx = lower_exp env e in
ctx @@@ ctx'
| `Val (name, rhs) ->
let rhs_v, rhs_ctx = lower_exp env rhs in
let set_ctx rest = Lir.Set (Ele (ob_v, name), rhs_v, rest) in
rhs_ctx @@@ set_ctx @@@ ctx'
| `Obj (name, body) ->
let ob_v, ob_ctx = lower_obj env body in
let set_ctx rest = Lir.Set (Ele (ob_v, name), ob_v, rest) in
ob_ctx @@@ set_ctx @@@ ctx')
Fun.id
inits
in
let slots = List.rev slots in
let ob_ctx rest = Lir.Let (ob, Obj { mthds; slots }, rest) in
ob_v, ob_ctx @@@ init_ctx
in
let std = gen_id "std" in
let std_env = Env.empty in
let std_env =
List.fold_left
(fun env fn -> Env.add fn (Var_fun (Arg std, fn)) env)
std_env
[ "read"; "print"; "itoa" ]
in
let std_env =
List.fold_left
(fun env var -> Env.add var (Var_ele (Arg std, var)) env)
std_env
[ "fs"; "rand" ]
in
let ret_v, ctx = lower_obj std_env modl.Syn.items in
let params = [ std ] in
let body = ctx (Lir.Ret ret_v) in
Lir.{ params; body }

View File

@ -7,6 +7,8 @@ type operand =
| Cst_int of int64
| Reg of regidx
let cst_of_int i = Cst_int (Int64.of_int i)
type basic_block = {
mutable ins_builder : ins list;
mutable ins_list : ins list;

View File

@ -1,5 +1,4 @@
module Syn = Spice_syntax.Ast
module Lir = Spice_lower.Lir
module Code = Spice_runtime.Code
module Value = Spice_runtime.Value
@ -13,9 +12,7 @@ let parse input =
| Spice_syntax.Parser.Error -> failf "syntax error"
| Spice_syntax.Lexer.Error msg -> failf "syntax error: %s" msg
let compile syn =
try Spice_lower.Normalize.to_anf syn
with Failure msg -> failf "compilation error: %s" msg
let compile ast = Spice_compile.Bcc.compile ast
let run prog =
try Spice_runtime.Interp.run_program prog