spice/lib/runtime/interp.ml

exception Runtime_error of string

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

module Op = struct
  let add v1 v2 =
    match v1, v2 with
    | Value.Int x, Value.Int y -> Value.Int (Int64.add x y)
    | _, _ -> runtime_error "cannot add non integer values"

  let sub v1 v2 =
    match v1, v2 with
    | Value.Int x, Value.Int y -> Value.Int (Int64.sub x y)
    | _, _ -> runtime_error "cannot sub non integer values"

  let mul v1 v2 =
    match v1, v2 with
    | Value.Int x, Value.Int y -> Value.Int (Int64.mul x y)
    | _, _ -> runtime_error "cannot mul non integer values"

  let eql v1 v2 =
    match v1, v2 with
    | Value.Int x, Value.Int y -> Value.bool (Int64.equal x y)
    | _, _ -> Value.bool (v1 == v2)

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

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

  let is_truthy = function
    | Value.False | Value.Nil -> false
    | _ -> true

  let not v = Value.bool (not (is_truthy v))

  let slt obj name =
    match obj with
    | Value.Obj (vtable, _) ->
      begin
        try Value.of_elem (Hashtbl.find vtable.elems name)
        with Not_found -> runtime_error "no such element %S" name
      end
    | _ -> runtime_error "get element of non-object"

  let get obj el =
    match obj, Value.to_elem el with
    | Value.Obj (_, slots), Field i -> slots.(i)
    | Value.Obj (_, _), Method _ -> failwith "Interp.Op.get: TODO: method reification"
    | exception Invalid_argument _ -> runtime_error "invalid index"
    | _ -> runtime_error "get field of non-object"

  let set obj el v =
    match obj, Value.to_elem el with
    | Value.Obj (_, slots), Field i -> slots.(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 el =
    match obj, Value.to_elem el with
    | Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i)
    | Value.Obj (_, _), Field _ -> failwith "Interp.Op.get: TODO: fcf calls"
    | exception Invalid_argument _ -> runtime_error "invalid index"
    | _ ->
      (* TODO: create vtable from primitive types *)
      runtime_error "call field of non-object"
end

type frame = {
  regs : Value.t array;
  mutable pc : Code.ins list;
}

let eval fr = function
  | Code.Cst_nil -> Value.Nil
  | Code.Cst_true -> Value.True
  | Code.Cst_false -> Value.False
  | Code.Cst_int n -> Value.Int n
  | Code.Reg i -> fr.regs.(i)

let rec exec fr = function
  | Code.MOV (l, r) -> fr.regs.(l) <- eval fr r
  | Code.ADD (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
  | Code.SUB (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
  | Code.MUL (l, r) -> fr.regs.(l) <- Op.mul fr.regs.(l) (eval fr r)
  | Code.EQL (l, r) -> fr.regs.(l) <- Op.eql fr.regs.(l) (eval fr r)
  | Code.LST (l, r) -> fr.regs.(l) <- Op.lst fr.regs.(l) (eval fr r)
  | Code.GRT (l, r) -> fr.regs.(l) <- Op.grt fr.regs.(l) (eval fr r)
  | Code.NOT l -> fr.regs.(l) <- Op.not fr.regs.(l)
  | Code.CON (l, vt) -> fr.regs.(l) <- Value.make_obj vt
  | Code.SLT (o, e, nm) -> fr.regs.(e) <- Op.slt fr.regs.(o) nm
  | Code.GET (o, e) -> fr.regs.(e) <- Op.get fr.regs.(o) fr.regs.(e)
  | Code.SET (o, e) -> Op.set fr.regs.(o) fr.regs.(e) fr.regs.(e + 1)
  | Code.RET -> fr.pc <- []
  | Code.CLL (o, m, k) ->
    let self, mthd = Op.mthd fr.regs.(o) fr.regs.(m) in
    let args = List.init k (fun i -> fr.regs.(m + i + 1)) in
    fr.regs.(m) <- call mthd self args
  | Code.JMP l -> fr.pc <- Code.instructions l
  | Code.CBR (v, l1, l2) ->
    fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2)

and call mthd self args =
  match mthd with
  | Code.Method pr ->
    if args <> [] then failwith "Interp.call: TODO: method arguments";
    run pr self
  | _ -> Value.call mthd self args

and run prog self =
  let frame_size = 1 in
  let frame_size = max frame_size (Code.frame_size prog) in
  let fr = {
    regs = Array.make frame_size Value.Nil;
    pc = Code.instructions prog.entrypoint;
  } in
  let rec run_loop () =
    match fr.pc with
    | [] -> ()
    | ins :: rest ->
      fr.pc <- rest;
      exec fr ins;
      run_loop ()
  in
  fr.regs.(0) <- self;
  run_loop ();
  fr.regs.(0)

let stdlib =
  let println vs =
    let pp ppf vs =
      List.iteri
        (fun i v ->
           if i > 0 then Fmt.pf ppf " ";
           Value.pp ppf v)
        vs
    in
    Fmt.pr "%a\n" pp vs;
    Value.Nil
  in
  let min = function
    | [] -> runtime_error "zero arguments to min()"
    | [ v ] -> v
    | v :: vs ->
      List.fold_left
        (fun v1 v2 ->
           match Op.lst v1 v2 with
           | Value.True -> v1
           | _ -> v2)
        v
        vs
  in
  let max = function
    | [] -> runtime_error "zero arguments to max()"
    | [ v ] -> v
    | v :: vs ->
      List.fold_left
        (fun v1 v2 ->
           match Op.grt v1 v2 with
           | Value.True -> v1
           | _ -> v2)
        v
        vs
  in
  [ "println", println; "min", min; "max", max ]