137 lines
4.2 KiB
OCaml
137 lines
4.2 KiB
OCaml
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 lhs rhs = if rhs <> Code.Reg lhs then emit (MOV (lhs, rhs)) 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, lhs, rhs) ->
|
|
let ret = !sp in
|
|
let lhs = compile_exp env lhs in
|
|
emit_mov ret lhs;
|
|
sp := ret + 1;
|
|
let rhs = compile_exp env rhs in
|
|
(match op with
|
|
| Ast.Add -> emit (ADD (ret, rhs))
|
|
| Ast.Sub -> emit (SUB (ret, rhs))
|
|
| Ast.Mul -> emit (MUL (ret, rhs))
|
|
| Ast.Div | Ast.Mod -> failwith "Bcc.compile_exp: TODO: div/mod"
|
|
| Ast.Eql -> emit (EQL (ret, rhs))
|
|
| Ast.Not_eql ->
|
|
emit (EQL (ret, rhs));
|
|
emit (NOT ret)
|
|
| Ast.Lst -> emit (LST (ret, rhs))
|
|
| Ast.Lst_eql ->
|
|
emit (LST (ret, rhs));
|
|
emit (NOT ret)
|
|
| Ast.Grt -> emit (GRT (ret, rhs))
|
|
| Ast.Grt_eql ->
|
|
emit (LST (ret, rhs));
|
|
emit (NOT ret));
|
|
Reg ret
|
|
| Ast.If (cnd, e1, e2) ->
|
|
let l1 = Code.make_basic_block [] in
|
|
let l2 = Code.make_basic_block [] in
|
|
let jp = Code.make_basic_block [] in
|
|
let tmp = !sp in
|
|
emit (CBR (compile_exp env cnd, l1, l2));
|
|
sp := tmp;
|
|
bb := l1;
|
|
emit_mov tmp (compile_exp env e1);
|
|
emit (JMP jp);
|
|
sp := tmp;
|
|
bb := l2;
|
|
emit_mov tmp (compile_exp env e2);
|
|
emit (JMP jp);
|
|
sp := tmp + 1;
|
|
bb := jp;
|
|
Reg tmp
|
|
| Ast.Obj body -> compile_obj env body
|
|
| Ast.Scope body -> compile_scope env body
|
|
| _ -> failwith "Bcc.compile_exp: TODO"
|
|
and compile_block 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, compile val fields, and get result of final expression *)
|
|
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
|
|
let final_exp =
|
|
List.fold_left
|
|
(fun _ -> function
|
|
| Ast.Item_fun (_, _, _) -> failwith "Bcc: unsupported: methods"
|
|
| Ast.Item_exp e ->
|
|
sp := self + 1;
|
|
Some (compile_exp env e)
|
|
| Ast.Item_obj (name, body) ->
|
|
sp := self + 2;
|
|
emit_set name (compile_obj env body);
|
|
None
|
|
| Ast.Item_val (name, rhs) ->
|
|
sp := self + 2;
|
|
emit_set name (compile_exp env rhs);
|
|
None)
|
|
None
|
|
items
|
|
in
|
|
self, final_exp
|
|
and compile_obj env items =
|
|
let self, _ = compile_block env items in
|
|
sp := self + 1;
|
|
Code.Reg self
|
|
and compile_scope env items =
|
|
match compile_block env items with
|
|
| _, None -> failwith "block must end with an expression"
|
|
| _, Some ret -> ret
|
|
in
|
|
|
|
let env = Env.empty in
|
|
emit_mov 0 (compile_obj env modl.Ast.items);
|
|
emit RET;
|
|
Code.make_program ep
|