spice/lib/runtime/interp.ml

exception Runtime_error of string

let runtime_error f =
  Fmt.kstr (fun s -> raise (Runtime_error s)) f

module Prim = struct
  let intop name ( ** ) v1 v2 =
    match v1, v2 with
    | Value.Int x, Value.Int y -> Value.Int (x ** y)
    | _, _ -> runtime_error "cannot %s non integer values" name

  let cmpop ( </> ) v1 v2 =
    match v1, v2 with
    | Value.Int x, Value.Int y -> Value.of_bool (Int64.compare x y </> 0)
    | _, _ -> runtime_error "cannot compare non integer values"

  let add = intop "add" Int64.add
  let sub = intop "sub" Int64.sub
  let mul = intop "mul" Int64.mul
  let lst = cmpop ( < )
  let grt = cmpop ( > )
  let eql v1 v2 = Value.of_bool (Value.equal v1 v2)
  let not v = Value.of_bool (not (Value.truthy v))

  let loc obj name =
    try
      match obj with
      | Value.Obj (vtable, _) ->
        Value.of_elem (Hashtbl.find vtable.elems name)
      | _ ->
        (* TODO: vtable of primitive types *)
        raise Not_found
    with
      Not_found -> runtime_error "no such element %S" name

  let get (obj, loc) =
    match obj, Value.to_elem loc with
    | Value.Obj (_, s), Field i -> s.(i)
    | Value.Obj (_, _), Method _ -> failwith "Interp.Prim.get: TODO: fcf"
    | exception Invalid_argument _ -> runtime_error "invalid index"
    | _ -> runtime_error "get field of non-object"

  let set (obj, loc) v =
    match obj, Value.to_elem loc with
    | Value.Obj (_, s), Field i -> s.(i) <- v
    | Value.Obj (_, _), Method _ -> runtime_error "cannot reassign method"
    | exception Invalid_argument _ -> runtime_error "invalid index"
    | _ -> runtime_error "set field of non-object"

  let mthd (obj, loc) =
    match obj, Value.to_elem loc with
    | Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i)
    | Value.Obj (_, _),      Field _ -> failwith "Interp.Prim.mthd: TODO: fcf"
    | exception Invalid_argument _ -> runtime_error "invalid index"
    | _ ->
      (* TODO: vtable of primitive types *)
      runtime_error "call method of non-object"
end

type frame = Value.t array

let get fr (`R a) = fr.(a)
let set fr (`R a) b = fr.(a) <- b
let arg fr = function
  | #Code.reg as r -> get fr r
  | `Cst v -> v

let opr = function
  | Code.ADD -> Prim.add
  | Code.SUB -> Prim.sub
  | Code.MUL -> Prim.mul
  | Code.DIV -> failwith "Interp: TODO(DIV)"
  | Code.MOD -> Prim.add
  | Code.NOT -> fun _ v -> Prim.not v
  | Code.NEG -> failwith "Interp: TODO(NEG)"
  | Code.Cmp EQ -> Prim.eql
  | Code.Cmp GT -> Prim.grt
  | Code.Cmp LT -> Prim.lst

let loc fr = function
  | a, (#Code.reg as b) -> get fr a, get fr b
  | a, (`Ofs ofs) -> get fr a, Value.of_int ofs

let rec run fn self args =
  let Code.{ n_args; frame_size; entry } = fn in
  if List.length args <> n_args then
    runtime_error "wrong number of arguments, expected %d, got %d"
      n_args (List.length args);

  let fr = Array.make frame_size Value.Nil in
  fr.(0) <- self;
  List.iteri (fun i v -> fr.(i + 1) <- v) args;

  step fr entry

and step fr t =
  match t.Code.edge with
  | I0 (Ret a) -> arg fr a

  | I1 (i, t1) ->
    begin match i with
      | Mov (a, b) -> set fr a (arg fr b)
      | Opr (op, a, b) -> set fr a (opr op (get fr a) (arg fr b))
      | Get (a, b) -> set fr a (Prim.get (loc fr b))
      | Set (bc, a) -> Prim.set (loc fr bc) (arg fr a)
      | Loc (a, b, nam) -> set fr a (Prim.loc (get fr b) nam)
      | Con (a, vtb) -> set fr a (Value.make_obj vtb)
      | Cal (a, f, args) ->
        let obj, mthd = Prim.mthd (loc fr f) in
        let args = List.map (arg fr) args in
        set fr a (call mthd obj args)
    end; step fr t1

  | I2 (i, t1, t2) ->
    let cond = match i with
      | IfT a -> Value.truthy (arg fr a)
      | i -> Fmt.failwith "TODO: Interp.step: %a" Code.pp_i2 i
    in
    step fr (if cond then t1 else t2)

and call mthd self args =
  match mthd with
  | Code.Function fn -> run fn self args
  | _ -> Value.call mthd self args