remove lir, add basic single pass compiler
This commit is contained in:
parent
846cae64ff
commit
c1eaa5baef
34
bin/main.ml
34
bin/main.ml
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(library
|
||||
(name spice_compile)
|
||||
(libraries spice_runtime spice_syntax))
|
||||
2
lib/dune
2
lib/dune
|
|
@ -1,3 +1,3 @@
|
|||
(library
|
||||
(name spice)
|
||||
(libraries fmt spice_syntax spice_lower spice_runtime))
|
||||
(libraries fmt spice_syntax spice_runtime spice_compile))
|
||||
|
|
|
|||
|
|
@ -1,3 +0,0 @@
|
|||
(library
|
||||
(name spice_lower)
|
||||
(libraries spice_syntax fmt))
|
||||
135
lib/lower/lir.ml
135
lib/lower/lir.ml
|
|
@ -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
|
||||
|
|
@ -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 }
|
||||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue