147 lines
3.7 KiB
OCaml
147 lines
3.7 KiB
OCaml
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
|
|
|
|
let undef_method =
|
|
Value.Native_function
|
|
(fun _ -> failwith "BUG: method undefined")
|
|
|
|
let rec compile_lambda (lam : Ir.lambda) =
|
|
let entrypoint = Code.make_block () in
|
|
let currb = ref entrypoint in
|
|
let emit i = Code.extend !currb i in
|
|
let enter b = currb := b in
|
|
|
|
let reg_of_id = Hashtbl.create 128 in
|
|
let set_reg id r =
|
|
if Hashtbl.mem reg_of_id id then
|
|
Fmt.failwith "BUG: '%a' reassigned" Ir.pp_id id;
|
|
Hashtbl.add reg_of_id id r
|
|
in
|
|
let get_reg id =
|
|
try Hashtbl.find reg_of_id id with
|
|
Not_found -> Fmt.failwith "BUG: '%a' unassigned" Ir.pp_id id
|
|
in
|
|
|
|
let rec emit_exp sp = function
|
|
| Ir.Var id ->
|
|
get_reg id
|
|
|
|
| Ir.Let (id, rhs, bdy) ->
|
|
emit_exp_s sp rhs;
|
|
set_reg id sp;
|
|
emit_exp (suc sp) bdy
|
|
|
|
| Ir.Seq (e1, e2) ->
|
|
emit_exp sp e1 |> ignore;
|
|
emit_exp sp e2
|
|
|
|
| ir ->
|
|
emit_exp_s sp ir;
|
|
sp
|
|
|
|
and emit_exp_s sp = function
|
|
| Ir.Lit im ->
|
|
emit (LDI (sp, im))
|
|
|
|
| Ir.Get path ->
|
|
let obj, loc = emit_path sp path in
|
|
emit (GET (sp, obj, loc))
|
|
|
|
| Ir.Set (path, rhs) ->
|
|
let obj, loc = emit_path sp path in
|
|
let rv = emit_exp (suc sp) rhs in
|
|
emit (SET (rv, obj, loc))
|
|
|
|
| Ir.Seq (e1, e2) ->
|
|
emit_exp sp e1 |> ignore;
|
|
emit_exp_s sp e2
|
|
|
|
| Ir.If (e0, e1, e2) ->
|
|
let b1 = Code.make_block () in
|
|
let b2 = Code.make_block () in
|
|
let b3 = Code.make_block () in
|
|
let c = emit_exp sp e0 in
|
|
emit (CBR (c, b1, b2));
|
|
enter b1; emit_exp_s sp e1; emit (JMP b3);
|
|
enter b2; emit_exp_s sp e2; emit (JMP b3);
|
|
enter b3
|
|
|
|
| Ir.Uop (op, e1) ->
|
|
let r1 = emit_exp sp e1 in
|
|
emit (match op with
|
|
| Not -> NOT (sp, r1))
|
|
|
|
| Ir.Bop (op, e1, e2) ->
|
|
let r1 = emit_exp sp e1 in
|
|
let r2 = emit_exp (suc sp) e2 in
|
|
emit (match op with
|
|
| Add -> ADD (sp, r1, r2)
|
|
| Sub -> SUB (sp, r1, r2)
|
|
| Mul -> MUL (sp, r1, r2)
|
|
| Div -> failwith "Bcc.compile_exp: TODO(Bop(Div))"
|
|
| Mod -> failwith "Bcc.compile_exp: TODO(Bop(Mod))"
|
|
| Eql -> EQL (sp, r1, r2)
|
|
| Grt -> GRT (sp, r1, r2)
|
|
| Lst -> LST (sp, r1, r2))
|
|
|
|
| Ir.Call (fn, args) ->
|
|
let obj, mth = emit_path sp fn in
|
|
let args =
|
|
List.mapi
|
|
(fun i arg ->
|
|
let rv = off mth (i + 1) in
|
|
emit_exp_s rv arg; rv)
|
|
args
|
|
in
|
|
emit (CAL (sp, obj, mth, args))
|
|
|
|
| Ir.Obj { vals; funs } ->
|
|
let n_slots = List.length vals in
|
|
let elems = Hashtbl.create (List.length vals + List.length funs) in
|
|
let mthds = Array.make (List.length funs) undef_method in
|
|
List.iteri
|
|
(fun i name ->
|
|
Hashtbl.add elems name (Value.Field i))
|
|
vals;
|
|
List.iteri
|
|
(fun i (name, lambda) ->
|
|
Hashtbl.add elems name (Value.Method i);
|
|
mthds.(i) <- Code.Function (compile_lambda lambda))
|
|
funs;
|
|
emit (CON (sp, { n_slots; elems; mthds }))
|
|
|
|
| ir ->
|
|
let rv = emit_exp sp ir in
|
|
if rv <> sp then emit (LDR (sp, rv))
|
|
|
|
and emit_path sp (obj, fld) =
|
|
let obj = get_reg obj in
|
|
let loc = sp in
|
|
emit (LOC (loc, obj, fld));
|
|
obj, loc
|
|
|
|
in
|
|
|
|
set_reg lam.self (Code.R 0);
|
|
let sp =
|
|
List.fold_left
|
|
(fun sp arg -> set_reg arg sp; suc sp)
|
|
(Code.R 1)
|
|
lam.args
|
|
in
|
|
let rv = emit_exp sp lam.body in
|
|
emit (RET rv);
|
|
|
|
Code.make_funct
|
|
(List.length lam.args)
|
|
entrypoint
|