spice/lib/compile/bcc.ml

module Ast = Spice_syntax.Ast
module Code = Spice_runtime.Code
module Value = Spice_runtime.Value
module Interp = Spice_runtime.Interp
module Env = Map.Make (String)

type binding = {
  self : Code.regidx;
  elem : Value.elem;
}

let compile modl =
  let ep = Code.make_basic_block [] 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 sp = 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; elem } ->
          let idx = Code.cst (Value.of_elem elem) in
          emit_mov sp idx;
          emit (GET (self, sp));
          Reg sp)
    | Ast.Path (Ele (obj, ele)) ->
      emit_mov (sp + 1) (compile_exp env sp obj);
      emit (SLT (sp + 1, sp, ele));
      emit (GET (sp + 1, sp));
      Reg sp
    | Ast.Call (Var name, args) -> (
        match Env.find name env with
        | exception Not_found -> Fmt.failwith "unbound: %S" name
        | { self; elem } ->
          List.iteri
            (fun i arg ->
               let sp = sp + i + 1 in
               emit_mov sp (compile_exp env sp arg))
            args;
          let idx = Code.cst (Value.of_elem elem) in
          emit_mov sp idx;
          emit (CLL (self, sp, List.length args));
          Reg sp)
    | Ast.Binop (op, lhs, rhs) ->
      let lhs = compile_exp env sp lhs in
      emit_mov sp lhs;
      let rhs = compile_exp env (sp + 1) rhs in
      (match op with
       | Ast.Add     -> emit (ADD (sp, rhs))
       | Ast.Sub     -> emit (SUB (sp, rhs))
       | Ast.Mul     -> emit (MUL (sp, rhs))
       | Ast.Div | Ast.Mod -> failwith "Bcc.compile_exp: TODO: div/mod"
       | Ast.Eql     -> emit (EQL (sp, rhs))
       | Ast.Not_eql -> emit (EQL (sp, rhs)); emit (NOT sp)
       | Ast.Lst     -> emit (LST (sp, rhs))
       | Ast.Lst_eql -> emit (LST (sp, rhs)); emit (NOT sp)
       | Ast.Grt     -> emit (GRT (sp, rhs))
       | Ast.Grt_eql -> emit (LST (sp, rhs)); emit (NOT sp));
      Reg sp
    | 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
      emit (CBR (compile_exp env sp cnd, l1, l2));
      bb := l1;
      emit_mov sp (compile_exp env sp e1);
      emit (JMP jp);
      bb := l2;
      emit_mov sp (compile_exp env sp e2);
      emit (JMP jp);
      bb := jp;
      Reg sp
    | Ast.Obj body -> compile_obj env sp body
    | Ast.Scope body -> compile_scope env sp body
    | _ -> failwith "Bcc.compile_exp: TODO"

  and compile_block env sp items =
    let self = sp in
    let sp = sp + 1 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 elem = Value.Field n in
             let env = Env.add name { self; elem } env in
             Hashtbl.add elems name elem;
             env, n + 1)
        (env, 0)
        items
    in

    (* compile methods *)
    let mthds = [||] in

    (* emit constructor, compile val fields, and get result of final expression *)
    let vtable = Value.{ n_slots; elems; mthds } in
    emit (CON (self, vtable));
    let emit_set name rhs =
      let { elem; _ } = Env.find name env in
      let idx = Code.cst (Value.of_elem elem) in
      emit_mov sp idx;
      emit_mov (sp + 1) rhs;
      emit (SET (self, sp))
    in
    let final_exp =
      List.fold_left
        (fun _ -> function
           | Ast.Item_fun (_, _, _) -> failwith "Bcc: unsupported: methods"
           | Ast.Item_exp exp ->
             Some (compile_exp env sp exp)
           | Ast.Item_obj (name, body) ->
             emit_set name (compile_obj env (sp + 1) body);
             None
           | Ast.Item_val (name, rhs) ->
             emit_set name (compile_exp env (sp + 1) rhs);
             None)
        None
        items
    in
    self, final_exp

  and compile_obj env sp items =
    let self, _ = compile_block env sp items in
    Code.Reg self
  and compile_scope env sp items =
    let _, final_exp = compile_block env sp items in
    match final_exp with
    | None -> failwith "block must end with an expression"
    | Some ret -> ret
  in

  let stdlib_env =
    List.to_seq Interp.stdlib
    |> Seq.mapi (fun i (name, _) -> name, { self = 0; elem = Value.Method i })
    |> Env.of_seq
  in
  emit_mov 0 (compile_obj stdlib_env 1 modl.Ast.items);
  emit RET;
  Code.make_program ep