refactor interpreter to use bytecode graph
This commit is contained in:
parent
31da3529a5
commit
f3954e6ca5
|
|
@ -1,25 +1,21 @@
|
||||||
module Ast = Spice_syntax.Ast
|
module Ast = Spice_syntax.Ast
|
||||||
module Code = Spice_runtime.Code
|
|
||||||
module Value = Spice_runtime.Value
|
module Value = Spice_runtime.Value
|
||||||
|
open Spice_runtime.Code
|
||||||
|
open B.Infix
|
||||||
|
|
||||||
exception Error of string
|
exception Error of string
|
||||||
|
|
||||||
let compile_error f =
|
let compile_error f =
|
||||||
Fmt.kstr (fun msg -> raise (Error msg)) f
|
Fmt.kstr (fun msg -> raise (Error msg)) f
|
||||||
|
|
||||||
let off (`R i) k = `R (i + k)
|
let add (`R i) k = `R (i + k)
|
||||||
let suc r = off r 1
|
let suc r = add r 1
|
||||||
|
|
||||||
let undef_method =
|
let undef_method =
|
||||||
Value.Native_function
|
Value.Native_function
|
||||||
(fun _ -> failwith "BUG: method undefined")
|
(fun _ -> failwith "BUG: method undefined")
|
||||||
|
|
||||||
let rec compile_lambda ?clos_map (lam : Ir.lambda) =
|
let rec compile_lambda ?clos_map (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 reg_of_id = Hashtbl.create 128 in
|
||||||
let set_reg id r =
|
let set_reg id r =
|
||||||
if Hashtbl.mem reg_of_id id then
|
if Hashtbl.mem reg_of_id id then
|
||||||
|
|
@ -31,81 +27,73 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) =
|
||||||
Not_found -> Fmt.failwith "BUG: '%a' unassigned" Ir.pp_id id
|
Not_found -> Fmt.failwith "BUG: '%a' unassigned" Ir.pp_id id
|
||||||
in
|
in
|
||||||
|
|
||||||
let rec emit_exp_v sp = function
|
let rec emit_exp_v sp : Ir.exp -> B.t * arg = function
|
||||||
| Ir.Lit v ->
|
| Ir.Lit v ->
|
||||||
`Cst v
|
B.empty, `Cst v
|
||||||
|
|
||||||
| Ir.Var id ->
|
| Ir.Var id ->
|
||||||
(get_reg id :> Code.arg)
|
B.empty, (get_reg id :> arg)
|
||||||
|
|
||||||
| Ir.Let (id, rhs, bdy) ->
|
| Ir.Let (id, rhs, bdy) ->
|
||||||
emit_exp_s sp rhs;
|
|
||||||
set_reg id sp;
|
set_reg id sp;
|
||||||
emit_exp_v (suc sp) bdy
|
let bc1 = emit_exp_s sp rhs in
|
||||||
|
let bc2, v = emit_exp_v (suc sp) bdy in
|
||||||
|
(bc1 +> bc2), v
|
||||||
|
|
||||||
| Ir.Seq (e1, e2) ->
|
| Ir.Seq (e1, e2) ->
|
||||||
emit_exp_v sp e1 |> ignore;
|
let bc1, _ = emit_exp_v sp e1 in
|
||||||
emit_exp_v sp e2
|
let bc2, v = emit_exp_v sp e2 in
|
||||||
|
(bc1 +> bc2), v
|
||||||
|
|
||||||
| ir ->
|
| ir ->
|
||||||
emit_exp_s sp ir;
|
emit_exp_s sp ir, (sp :> arg)
|
||||||
(sp :> Code.arg)
|
|
||||||
|
|
||||||
and emit_exp_s sp : Ir.exp -> unit = function
|
and emit_exp_s sp : Ir.exp -> B.t = function
|
||||||
| Ir.Get path ->
|
| Ir.Get path ->
|
||||||
let loc = emit_path sp path in
|
let bc1, loc = emit_path sp path in
|
||||||
emit (Get (sp, loc))
|
bc1 +> B.get sp loc
|
||||||
|
|
||||||
| Ir.Set (path, rhs) ->
|
| Ir.Set (path, rhs) ->
|
||||||
let loc = emit_path sp path in
|
let bc1, loc = emit_path sp path in
|
||||||
let rv = emit_exp_v (suc sp) rhs in
|
let bc2, rv = emit_exp_v (suc sp) rhs in
|
||||||
emit (Set (loc, rv))
|
bc1 +> bc2 +> B.set loc rv
|
||||||
|
|
||||||
| Ir.Seq (e1, e2) ->
|
| Ir.Seq (e1, e2) ->
|
||||||
emit_exp_v sp e1 |> ignore;
|
let bc1, _ = emit_exp_v sp e1 in
|
||||||
emit_exp_s sp e2
|
let bc2 = emit_exp_s sp e2 in
|
||||||
|
bc1 +> bc2
|
||||||
|
|
||||||
| Ir.If (e0, e1, e2) ->
|
| Ir.If (e0, e1, e2) ->
|
||||||
let b1 = Code.make_block () in
|
let bc0, v0 = emit_exp_v sp e0 in
|
||||||
let b2 = Code.make_block () in
|
let bc1 = emit_exp_s sp e1 in
|
||||||
let b3 = Code.make_block () in
|
let bc2 = emit_exp_s sp e2 in
|
||||||
let c = emit_exp_v sp e0 in
|
bc0 +> B.if_ v0 bc1 bc2
|
||||||
emit (Btr (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) ->
|
| Ir.Uop (op, e1) ->
|
||||||
let v1 = emit_exp_v sp e1 in
|
let op = match op with Not -> B.not_ in
|
||||||
let op = match op with Not -> Code.NOT in
|
let bc1, v1 = emit_exp_v sp e1 in
|
||||||
emit (Opr (op, sp, v1))
|
bc1 +> op sp v1
|
||||||
|
|
||||||
| Ir.Bop (op, e1, e2) ->
|
| Ir.Bop (op, e1, e2) ->
|
||||||
let op = match op with
|
let op = match op with
|
||||||
| Add -> Code.ADD
|
| Add -> B.add
|
||||||
| Sub -> Code.SUB
|
| Sub -> B.sub
|
||||||
| Mul -> Code.MUL
|
| Mul -> B.mul
|
||||||
| Div -> Code.DIV
|
| Div -> B.div
|
||||||
| Mod -> Code.MOD
|
| Mod -> B.mod_
|
||||||
| Eql -> Code.Cmp EQ
|
| Eql -> B.ceq
|
||||||
| Grt -> Code.Cmp GT
|
| Grt -> B.cgt
|
||||||
| Lst -> Code.Cmp LT
|
| Lst -> B.clt
|
||||||
in
|
in
|
||||||
emit_exp_s sp e1;
|
let bc1 = emit_exp_s sp e1 in
|
||||||
let v2 = emit_exp_v (suc sp) e2 in
|
let bc2, v2 = emit_exp_v (suc sp) e2 in
|
||||||
emit (Opr (op, sp, v2))
|
bc1 +> bc2 +> op sp v2
|
||||||
|
|
||||||
| Ir.Call (fn, args) ->
|
| Ir.Call (fn, args) ->
|
||||||
let fn = emit_path sp fn in
|
let bc0, fn = emit_path sp fn in
|
||||||
let args_r, _ =
|
let argvs = List.mapi (fun i _ -> add sp (i + 1)) args in
|
||||||
List.fold_left
|
let bc1 = B.concat (List.map2 emit_exp_s argvs args) in
|
||||||
(fun (args, sp) arg ->
|
bc0 +> bc1 +> B.cal sp fn argvs
|
||||||
emit_exp_s sp arg;
|
|
||||||
sp :: args, suc sp)
|
|
||||||
([], suc sp)
|
|
||||||
args
|
|
||||||
in
|
|
||||||
emit (Cal (sp, fn, List.rev args_r))
|
|
||||||
|
|
||||||
| Ir.Obj { vals; funs; clos } ->
|
| Ir.Obj { vals; funs; clos } ->
|
||||||
(* assign each captured id to a slot *)
|
(* assign each captured id to a slot *)
|
||||||
|
|
@ -130,18 +118,21 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) =
|
||||||
let mthds = Array.make (List.length funs) undef_method in
|
let mthds = Array.make (List.length funs) undef_method in
|
||||||
List.iteri
|
List.iteri
|
||||||
(fun i (name, lambda) ->
|
(fun i (name, lambda) ->
|
||||||
|
let funct = compile_lambda lambda ~clos_map in
|
||||||
Hashtbl.add elems name (Value.Method i);
|
Hashtbl.add elems name (Value.Method i);
|
||||||
mthds.(i) <- Code.Function (compile_lambda lambda ~clos_map))
|
mthds.(i) <- Function funct)
|
||||||
funs;
|
funs;
|
||||||
|
|
||||||
(* construct object and save captured id's *)
|
(* construct object and save captured id's *)
|
||||||
let vtb : Code.vtable = { n_slots; elems; mthds } in
|
let bc0 = B.con sp { n_slots; mthds; elems } in
|
||||||
emit (Con (sp, vtb));
|
(* Hashtbl.iter *)
|
||||||
Hashtbl.iter
|
(* clos_map *)
|
||||||
(fun cap_id clos_ofs ->
|
Hashtbl.fold
|
||||||
let cap_v = (get_reg cap_id :> Code.arg) in
|
(fun cap_id clos_ofs bc ->
|
||||||
emit (Set ((sp, clos_ofs), cap_v)))
|
bc +> B.set (sp, clos_ofs)
|
||||||
|
(get_reg cap_id :> arg))
|
||||||
clos_map
|
clos_map
|
||||||
|
bc0
|
||||||
|
|
||||||
| Ir.Open id ->
|
| Ir.Open id ->
|
||||||
let clos = get_reg lam.self in
|
let clos = get_reg lam.self in
|
||||||
|
|
@ -149,18 +140,19 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) =
|
||||||
with Not_found -> failwith "BUG: %S not captured"
|
with Not_found -> failwith "BUG: %S not captured"
|
||||||
| Invalid_argument _ -> failwith "BUG: no captured variables"
|
| Invalid_argument _ -> failwith "BUG: no captured variables"
|
||||||
in
|
in
|
||||||
emit (Get (sp, (clos, ofs)))
|
B.get sp (clos, ofs)
|
||||||
|
|
||||||
| ir ->
|
| ir ->
|
||||||
let rv = emit_exp_v sp ir in
|
let bc, rv = emit_exp_v sp ir in
|
||||||
if rv <> (sp :> Code.arg) then
|
if rv = (sp :> arg) then
|
||||||
emit (Mov (sp, rv))
|
bc
|
||||||
|
else
|
||||||
|
bc +> B.mov sp rv
|
||||||
|
|
||||||
and emit_path sp (obj, fld) =
|
and emit_path sp (obj, fld) : B.t * loc =
|
||||||
let obj = get_reg obj in
|
let obj = get_reg obj in
|
||||||
let loc = sp in
|
let loc = sp in
|
||||||
emit (Loc (loc, obj, fld));
|
B.loc loc obj fld, (obj, (loc :> ofs))
|
||||||
obj, (loc :> Code.ofs)
|
|
||||||
|
|
||||||
in
|
in
|
||||||
|
|
||||||
|
|
@ -173,9 +165,10 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) =
|
||||||
(`R 1)
|
(`R 1)
|
||||||
lam.args
|
lam.args
|
||||||
in
|
in
|
||||||
let rv = emit_exp_v sp lam.body in
|
|
||||||
emit (Ret rv);
|
|
||||||
|
|
||||||
Code.make_funct
|
let bc, rv = emit_exp_v sp lam.body in
|
||||||
|
let ep = bc |> B.ret rv in
|
||||||
|
|
||||||
|
make_funct
|
||||||
(List.length lam.args)
|
(List.length lam.args)
|
||||||
entrypoint
|
ep
|
||||||
|
|
|
||||||
|
|
@ -1,228 +0,0 @@
|
||||||
module Value = Spice_runtime.Value
|
|
||||||
|
|
||||||
(* instruction operand types, etc. *)
|
|
||||||
|
|
||||||
type reg = [`R of int]
|
|
||||||
type cst = [`Cst of Value.t]
|
|
||||||
type arg = [reg | cst]
|
|
||||||
type ofs = [reg | `Ofs of int]
|
|
||||||
type loc = reg * ofs
|
|
||||||
|
|
||||||
type opr = NOT | NEG | ADD | SUB | MUL | DIV | MOD | Cmp of cnd
|
|
||||||
and cnd = EQ | LT | GT (* | NE | LE | GE *)
|
|
||||||
|
|
||||||
type vtable =
|
|
||||||
VTABLE
|
|
||||||
|
|
||||||
(* instruction types (suffix denotes number of successors) *)
|
|
||||||
|
|
||||||
type i0 =
|
|
||||||
| Ret of arg
|
|
||||||
|
|
||||||
type i1 =
|
|
||||||
| Mov of reg * arg
|
|
||||||
| Opr of opr * reg * arg
|
|
||||||
| Get of reg * loc
|
|
||||||
| Set of loc * arg
|
|
||||||
| Con of reg * vtable
|
|
||||||
| Loc of reg * reg * string
|
|
||||||
| Cal of reg * loc * reg list
|
|
||||||
|
|
||||||
type i2 =
|
|
||||||
| IfT of arg
|
|
||||||
| IfC of cnd * reg * arg
|
|
||||||
|
|
||||||
(* bytecode graph nodes *)
|
|
||||||
|
|
||||||
type t = {
|
|
||||||
mutable edge : edge;
|
|
||||||
mutable label : string option;
|
|
||||||
mutable preds : int;
|
|
||||||
}
|
|
||||||
|
|
||||||
and edge =
|
|
||||||
| I0 of i0
|
|
||||||
| I1 of i1 * t
|
|
||||||
| I2 of i2 * t * t
|
|
||||||
|
|
||||||
let make edge = {
|
|
||||||
edge;
|
|
||||||
label = None;
|
|
||||||
preds = 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
(* helper module for constructing and combining bytecode graphs *)
|
|
||||||
|
|
||||||
module B = struct
|
|
||||||
type nonrec bcg = t
|
|
||||||
type t = { build : bcg -> bcg } [@@unboxed]
|
|
||||||
|
|
||||||
let empty =
|
|
||||||
{build = Fun.id}
|
|
||||||
|
|
||||||
let append t1 t2 =
|
|
||||||
{build = fun b -> t1.build (t2.build b)}
|
|
||||||
|
|
||||||
let concat ts =
|
|
||||||
let ts_r = List.rev ts in
|
|
||||||
{build = fun b -> List.fold_left (fun b t -> t.build b) b ts_r}
|
|
||||||
|
|
||||||
(* let fix (f : t -> t) : t = *)
|
|
||||||
(* let _ = f in failwith "TODO: B.fix" *)
|
|
||||||
|
|
||||||
module Infix = struct
|
|
||||||
let ( +> ) = append
|
|
||||||
end
|
|
||||||
|
|
||||||
module Private = struct
|
|
||||||
let i0 (i : i0) (b : t) : bcg =
|
|
||||||
b.build (make (I0 i))
|
|
||||||
|
|
||||||
let i1 (i : i1) : t =
|
|
||||||
{build = fun t -> make (I1 (i, t))}
|
|
||||||
|
|
||||||
let i2 (i : i2) (b1 : t) (b2 : t) : t =
|
|
||||||
{build = fun b -> make (I2 (i, b1.build b, b2.build b))}
|
|
||||||
end
|
|
||||||
|
|
||||||
open Private
|
|
||||||
|
|
||||||
let nil = `Cst Value.Nil
|
|
||||||
let int64 x = `Cst (Value.Int x)
|
|
||||||
let int x = int64 (Int64.of_int x)
|
|
||||||
|
|
||||||
let mov dst src = i1 (Mov (dst, src))
|
|
||||||
let opr op dst src = i1 (Opr (op, dst, src))
|
|
||||||
let get dst loc = i1 (Get (dst, loc))
|
|
||||||
let set loc src = i1 (Set (loc, src))
|
|
||||||
let con dst vtb = i1 (Con (dst, vtb))
|
|
||||||
let loc dst src nam = i1 (Loc (dst, src, nam))
|
|
||||||
let cal dst fn args =
|
|
||||||
(* TODO: check if fn,args well formed *)
|
|
||||||
i1 (Cal (dst, fn, args))
|
|
||||||
let ret v = i0 (Ret v)
|
|
||||||
let if_ = function
|
|
||||||
| #arg as x -> i2 (IfT x)
|
|
||||||
| `Cmp (c, x, y) -> i2 (IfC (c, x, y))
|
|
||||||
|
|
||||||
let add = opr ADD
|
|
||||||
let sub = opr SUB
|
|
||||||
let mul = opr MUL
|
|
||||||
let div = opr DIV
|
|
||||||
let mod_= opr MOD
|
|
||||||
let not_= opr NOT
|
|
||||||
let neg = opr NEG
|
|
||||||
let ceq = opr (Cmp EQ)
|
|
||||||
let cgt = opr (Cmp GT)
|
|
||||||
let clt = opr (Cmp LT)
|
|
||||||
end
|
|
||||||
|
|
||||||
(* pretty printer *)
|
|
||||||
|
|
||||||
let pp_reg ppf (`R i) =
|
|
||||||
Fmt.pf ppf "R%d" i
|
|
||||||
|
|
||||||
let pp_arg ppf = function
|
|
||||||
| #reg as r -> pp_reg ppf r
|
|
||||||
| `Cst v -> Value.pp ppf v
|
|
||||||
|
|
||||||
let pp_loc ppf = function
|
|
||||||
| (r, (#reg as i)) -> Fmt.pf ppf "%a[%a]" pp_reg r pp_reg i
|
|
||||||
| (r, `Ofs ofs) -> Fmt.pf ppf "%a[%d]" pp_reg r ofs
|
|
||||||
|
|
||||||
let pp_vtable ppf VTABLE = Fmt.pf ppf "{}"
|
|
||||||
|
|
||||||
let string_of_cnd ~prefix = function
|
|
||||||
| EQ -> prefix ^ "eq"
|
|
||||||
| GT -> prefix ^ "gt"
|
|
||||||
| LT -> prefix ^ "lt"
|
|
||||||
|
|
||||||
let string_of_opr = function
|
|
||||||
| NOT -> "not"
|
|
||||||
| NEG -> "neg"
|
|
||||||
| ADD -> "add"
|
|
||||||
| SUB -> "sub"
|
|
||||||
| MUL -> "mul"
|
|
||||||
| DIV -> "div"
|
|
||||||
| MOD -> "mod"
|
|
||||||
| Cmp c -> string_of_cnd c ~prefix:"c"
|
|
||||||
|
|
||||||
let pp_i0 ppf = function
|
|
||||||
| Ret a -> Fmt.pf ppf "ret %a" pp_arg a
|
|
||||||
|
|
||||||
let pp_i1 ppf = function
|
|
||||||
| Mov (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_arg b
|
|
||||||
| Opr (o, a, b) -> Fmt.pf ppf "%s %a, %a" (string_of_opr o) pp_reg a pp_arg b
|
|
||||||
| Get (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_loc b
|
|
||||||
| Set (a, b) -> Fmt.pf ppf "mov %a, %a" pp_loc a pp_arg b
|
|
||||||
| Loc (a, b, nam) -> Fmt.pf ppf "loc %a, %a.<%s>" pp_reg a pp_reg b nam
|
|
||||||
| Con (a, vtb) -> Fmt.pf ppf "con %a, %a" pp_reg a pp_vtable vtb
|
|
||||||
| Cal (r, f, args) ->
|
|
||||||
Fmt.pf ppf "cal %a, %a(" pp_reg r pp_loc f;
|
|
||||||
List.iteri (fun i a -> if i > 0 then Fmt.pf ppf ","; pp_reg ppf a) args;
|
|
||||||
Fmt.pf ppf ")"
|
|
||||||
|
|
||||||
let pp_i2 ppf = function
|
|
||||||
| IfT v -> Fmt.pf ppf "btr %a" pp_arg v
|
|
||||||
| IfC (c, a, b) ->
|
|
||||||
let name = string_of_cnd c ~prefix:"b" in
|
|
||||||
Fmt.pf ppf "%s %a, %a" name pp_reg a pp_arg b
|
|
||||||
|
|
||||||
let generate_labels ep =
|
|
||||||
let nl = ref 0 in
|
|
||||||
let rec go t require =
|
|
||||||
t.preds <- t.preds + 1;
|
|
||||||
if t.label = None && (t.preds > 1 || require) then begin
|
|
||||||
t.label <- Some (Fmt.str "L%d" !nl);
|
|
||||||
incr nl
|
|
||||||
end;
|
|
||||||
if t.preds = 1 then begin
|
|
||||||
match t.edge with
|
|
||||||
| I0 _ -> ()
|
|
||||||
| I1 (_, t1) -> go t1 false
|
|
||||||
| I2 (_, t1, t2) -> go t1 false; go t2 true
|
|
||||||
end
|
|
||||||
in
|
|
||||||
ep.label <- Some "EP";
|
|
||||||
go ep false
|
|
||||||
|
|
||||||
let dump println ep =
|
|
||||||
let printf ?l fmt =
|
|
||||||
let margin = match l with
|
|
||||||
| None -> ""
|
|
||||||
| Some l -> l ^ ":"
|
|
||||||
in
|
|
||||||
Fmt.kstr println ("%-8s" ^^ fmt) margin
|
|
||||||
in
|
|
||||||
|
|
||||||
let rec pr t =
|
|
||||||
if t.preds = 0 then
|
|
||||||
pr_jmp t
|
|
||||||
else begin
|
|
||||||
t.preds <- 0;
|
|
||||||
match t.edge with
|
|
||||||
| I0 i ->
|
|
||||||
printf ?l:t.label "%a" pp_i0 i
|
|
||||||
|
|
||||||
| I1 (i, t1) ->
|
|
||||||
printf ?l:t.label "%a" pp_i1 i;
|
|
||||||
pr t1
|
|
||||||
|
|
||||||
| I2 (i, t1, t2) ->
|
|
||||||
printf ?l:t.label "%a" pp_i2 i;
|
|
||||||
pr_jmp t2;
|
|
||||||
pr t1;
|
|
||||||
maybe_pr t2
|
|
||||||
end
|
|
||||||
|
|
||||||
and pr_jmp t =
|
|
||||||
printf "jmp %s" (Option.get t.label)
|
|
||||||
|
|
||||||
and maybe_pr t =
|
|
||||||
if t.preds > 0 then
|
|
||||||
pr t
|
|
||||||
|
|
||||||
in
|
|
||||||
|
|
||||||
generate_labels ep;
|
|
||||||
pr ep
|
|
||||||
|
|
@ -1,7 +1,4 @@
|
||||||
module Ast = Spice_syntax.Ast
|
(* instruction operand types, etc. *)
|
||||||
|
|
||||||
type imm = Value.t
|
|
||||||
type vtable = Value.vtable
|
|
||||||
|
|
||||||
type reg = [`R of int]
|
type reg = [`R of int]
|
||||||
type cst = [`Cst of Value.t]
|
type cst = [`Cst of Value.t]
|
||||||
|
|
@ -10,119 +7,177 @@ type ofs = [reg | `Ofs of int]
|
||||||
type loc = reg * ofs
|
type loc = reg * ofs
|
||||||
|
|
||||||
type opr = NOT | NEG | ADD | SUB | MUL | DIV | MOD | Cmp of cnd
|
type opr = NOT | NEG | ADD | SUB | MUL | DIV | MOD | Cmp of cnd
|
||||||
and cnd = EQ | LT | GT
|
and cnd = EQ | LT | GT (* | NE | LE | GE *)
|
||||||
(* and cnd = EQ | NE | LT | GE | GT | LE *)
|
|
||||||
|
|
||||||
type ins =
|
(* instruction types (suffix denotes number of successors) *)
|
||||||
|
|
||||||
|
type i0 =
|
||||||
|
| Ret of arg
|
||||||
|
|
||||||
|
type i1 =
|
||||||
| Mov of reg * arg
|
| Mov of reg * arg
|
||||||
| Opr of opr * reg * arg
|
| Opr of opr * reg * arg
|
||||||
| Get of reg * loc
|
| Get of reg * loc
|
||||||
| Set of loc * arg
|
| Set of loc * arg
|
||||||
| Con of reg * vtable
|
| Con of reg * Value.vtable
|
||||||
| Loc of reg * reg * string
|
| Loc of reg * reg * string
|
||||||
| Cal of reg * loc * reg list
|
| Cal of reg * loc * reg list
|
||||||
| Btr of arg * block * block
|
|
||||||
| Jmp of block
|
|
||||||
| Ret of arg
|
|
||||||
|
|
||||||
and block =
|
type i2 =
|
||||||
{ mutable ins_list_rev : ins list }
|
| IfT of arg
|
||||||
|
| IfC of cnd * reg * arg
|
||||||
|
|
||||||
let arg_regs = function
|
(* bytecode graph nodes *)
|
||||||
| #reg as r -> [r]
|
|
||||||
| #cst -> []
|
|
||||||
|
|
||||||
let loc_regs = function
|
type t = {
|
||||||
| (r1, (#reg as r2)) -> [r1; r2]
|
mutable edge : edge;
|
||||||
| (r1, #ofs) -> [r1]
|
mutable label : string option;
|
||||||
|
mutable preds : int;
|
||||||
|
}
|
||||||
|
|
||||||
let registers = function
|
and edge =
|
||||||
| Ret v
|
| I0 of i0
|
||||||
| Btr (v, _, _) -> arg_regs v
|
| I1 of i1 * t
|
||||||
| Mov (r, v)
|
| I2 of i2 * t * t
|
||||||
| Opr (_, r, v) -> r :: arg_regs v
|
|
||||||
| Get (r, l) -> r :: loc_regs l
|
|
||||||
| Set (l, v) -> arg_regs v @ loc_regs l
|
|
||||||
| Con (r, _) -> [r]
|
|
||||||
| Loc (r1, r2, _) -> [r1; r2]
|
|
||||||
| Cal (r, l, rs) -> loc_regs l @ r :: rs
|
|
||||||
| Jmp _ -> []
|
|
||||||
|
|
||||||
let make_block () =
|
let make edge = {
|
||||||
{ ins_list_rev = [] }
|
edge;
|
||||||
|
label = None;
|
||||||
|
preds = 0;
|
||||||
|
}
|
||||||
|
|
||||||
let extend b ins =
|
let sucs = function
|
||||||
b.ins_list_rev <- ins :: b.ins_list_rev
|
| I0 _ -> []
|
||||||
|
| I1 (_, t) -> [t]
|
||||||
|
| I2 (_, t1, t2) -> [t1; t2]
|
||||||
|
|
||||||
let instructions b =
|
let registers e =
|
||||||
List.rev b.ins_list_rev
|
let arg = function #reg as r -> [r] | _ -> [] in
|
||||||
|
let loc (r, o) = r :: arg o in
|
||||||
|
match e with
|
||||||
|
| I0 (Ret a) -> arg a
|
||||||
|
| I1 (Mov (a, b), _) -> a :: arg b
|
||||||
|
| I1 (Opr (_, a, b), _) -> a :: arg b
|
||||||
|
| I1 (Get (a, b), _) -> a :: loc b
|
||||||
|
| I1 (Set (a, b), _) -> loc a @ arg b
|
||||||
|
| I1 (Con (a, _), _) -> [a]
|
||||||
|
| I1 (Loc (a, b, _), _) -> [a; b]
|
||||||
|
| I1 (Cal (a, f, bs), _) -> a :: loc f @ bs
|
||||||
|
| I2 (IfT a, _, _) -> arg a
|
||||||
|
| I2 (IfC (_, a, b), _, _) -> a :: arg b
|
||||||
|
|
||||||
let iter_blocks_df f b0 =
|
let preorder t0 =
|
||||||
let queue = ref [ b0 ] in
|
let rec go t =
|
||||||
let visited = ref !queue in
|
t.preds <- t.preds + 1;
|
||||||
let enqueue b =
|
if t.preds = 1 then
|
||||||
if not (List.memq b !visited) then (
|
t :: List.flatten (List.map go (sucs t.edge))
|
||||||
queue := !queue @ [b];
|
else
|
||||||
visited := b :: !visited)
|
[]
|
||||||
in
|
in
|
||||||
let rec loop () =
|
List.map (fun t -> t.preds <- 0; t) (go t0)
|
||||||
match !queue with
|
|
||||||
| [] -> ()
|
|
||||||
| b :: rest ->
|
|
||||||
queue := rest;
|
|
||||||
f b;
|
|
||||||
(* NOTE: only [List.hd b.ins_list_rev] should be a branching instruction, so iterating
|
|
||||||
the whole list is pointless. but just to be safe ... *)
|
|
||||||
List.iter
|
|
||||||
(function
|
|
||||||
| Jmp b1 -> enqueue b1
|
|
||||||
| Btr (_, b1, b2) -> enqueue b1; enqueue b2
|
|
||||||
| _ -> ())
|
|
||||||
b.ins_list_rev;
|
|
||||||
loop ()
|
|
||||||
in
|
|
||||||
loop ()
|
|
||||||
|
|
||||||
|
(* functions *)
|
||||||
|
|
||||||
type funct =
|
type funct = {
|
||||||
{ n_args : int;
|
n_args : int;
|
||||||
frame_size : int;
|
frame_size : int;
|
||||||
entry : block }
|
entry : t
|
||||||
|
}
|
||||||
|
|
||||||
type Value.mthd +=
|
type Value.mthd +=
|
||||||
| Function of funct
|
| Function of funct
|
||||||
|
|
||||||
let make_funct n_args entry =
|
let make_funct n_args entry =
|
||||||
let frame_size =
|
let frame_size =
|
||||||
let fsize = ref (n_args + 1) in
|
List.map (fun t -> registers t.edge) (preorder entry)
|
||||||
iter_blocks_df
|
|> List.flatten
|
||||||
(fun b ->
|
|> List.fold_left
|
||||||
fsize :=
|
(fun fs (`R i) -> max fs (i + 1))
|
||||||
List.rev_map registers b.ins_list_rev
|
(n_args + 1)
|
||||||
|> List.flatten
|
|
||||||
|> List.fold_left (fun fs (`R i) -> max fs (i + 1))
|
|
||||||
!fsize)
|
|
||||||
entry;
|
|
||||||
!fsize
|
|
||||||
in
|
in
|
||||||
{ n_args; frame_size; entry }
|
{ n_args; frame_size; entry }
|
||||||
|
|
||||||
|
(* helper module for constructing and combining bytecode graphs *)
|
||||||
|
|
||||||
(* pretty printing *)
|
module B = struct
|
||||||
|
type nonrec bcg = t
|
||||||
|
type t = { build : bcg -> bcg } [@@unboxed]
|
||||||
|
|
||||||
|
let empty =
|
||||||
|
{build = Fun.id}
|
||||||
|
|
||||||
|
let append t1 t2 =
|
||||||
|
{build = fun b -> t1.build (t2.build b)}
|
||||||
|
|
||||||
|
let concat ts =
|
||||||
|
let ts_r = List.rev ts in
|
||||||
|
{build = fun b -> List.fold_left (fun b t -> t.build b) b ts_r}
|
||||||
|
|
||||||
|
(* let fix (f : t -> t) : t = *)
|
||||||
|
(* let _ = f in failwith "TODO: B.fix" *)
|
||||||
|
|
||||||
|
module Infix = struct
|
||||||
|
let ( +> ) = append
|
||||||
|
end
|
||||||
|
|
||||||
|
module Private = struct
|
||||||
|
let i0 (i : i0) (b : t) : bcg =
|
||||||
|
b.build (make (I0 i))
|
||||||
|
|
||||||
|
let i1 (i : i1) : t =
|
||||||
|
{build = fun t -> make (I1 (i, t))}
|
||||||
|
|
||||||
|
let i2 (i : i2) (b1 : t) (b2 : t) : t =
|
||||||
|
{build = fun b -> make (I2 (i, b1.build b, b2.build b))}
|
||||||
|
end
|
||||||
|
|
||||||
|
open Private
|
||||||
|
|
||||||
|
let nil = `Cst Value.Nil
|
||||||
|
let int64 x = `Cst (Value.Int x)
|
||||||
|
let int x = int64 (Int64.of_int x)
|
||||||
|
|
||||||
|
let mov dst src = i1 (Mov (dst, src))
|
||||||
|
let opr op dst src = i1 (Opr (op, dst, src))
|
||||||
|
let get dst loc = i1 (Get (dst, loc))
|
||||||
|
let set loc src = i1 (Set (loc, src))
|
||||||
|
let con dst vtb = i1 (Con (dst, vtb))
|
||||||
|
let loc dst src nam = i1 (Loc (dst, src, nam))
|
||||||
|
let cal dst fn args =
|
||||||
|
(* TODO: check if fn,args well formed *)
|
||||||
|
i1 (Cal (dst, fn, args))
|
||||||
|
let ret v = i0 (Ret v)
|
||||||
|
let if_ = function
|
||||||
|
| #arg as x -> i2 (IfT x)
|
||||||
|
| `Cmp (c, x, y) -> i2 (IfC (c, x, y))
|
||||||
|
|
||||||
|
let add = opr ADD
|
||||||
|
let sub = opr SUB
|
||||||
|
let mul = opr MUL
|
||||||
|
let div = opr DIV
|
||||||
|
let mod_= opr MOD
|
||||||
|
let not_= opr NOT
|
||||||
|
let neg = opr NEG
|
||||||
|
let ceq = opr (Cmp EQ)
|
||||||
|
let cgt = opr (Cmp GT)
|
||||||
|
let clt = opr (Cmp LT)
|
||||||
|
end
|
||||||
|
|
||||||
|
(* pretty printer *)
|
||||||
|
|
||||||
let pp_reg ppf (`R i) =
|
let pp_reg ppf (`R i) =
|
||||||
Fmt.pf ppf "R%d" i
|
Fmt.pf ppf "R%d" i
|
||||||
|
|
||||||
let pp_arg ppf = function
|
let pp_arg ppf = function
|
||||||
| #reg as r -> pp_reg ppf r
|
| #reg as r -> pp_reg ppf r
|
||||||
| `Cst c -> Value.pp ppf c
|
| `Cst v -> Value.pp ppf v
|
||||||
|
|
||||||
let pp_loc ppf = function
|
let pp_loc ppf = function
|
||||||
| (r, (#reg as i)) -> Fmt.pf ppf "%a[%a]" pp_reg r pp_reg i
|
| (r, (#reg as i)) -> Fmt.pf ppf "%a[%a]" pp_reg r pp_reg i
|
||||||
| (r, `Ofs ofs) -> Fmt.pf ppf "%a[%d]" pp_reg r ofs
|
| (r, `Ofs ofs) -> Fmt.pf ppf "%a[%d]" pp_reg r ofs
|
||||||
|
|
||||||
let pp_vtable ~tbname ppf (vtb : vtable) =
|
let pp_vtable ppf (vtb : Value.vtable) =
|
||||||
Fmt.pf ppf "%s(%d){" (tbname vtb) vtb.n_slots;
|
Fmt.pf ppf "(%d){" vtb.n_slots;
|
||||||
let sep = ref "" in
|
let sep = ref "" in
|
||||||
Hashtbl.iter
|
Hashtbl.iter
|
||||||
(fun name -> function
|
(fun name -> function
|
||||||
|
|
@ -133,6 +188,11 @@ let pp_vtable ~tbname ppf (vtb : vtable) =
|
||||||
vtb.elems;
|
vtb.elems;
|
||||||
Fmt.pf ppf "}"
|
Fmt.pf ppf "}"
|
||||||
|
|
||||||
|
let string_of_cnd ~prefix = function
|
||||||
|
| EQ -> prefix ^ "eq"
|
||||||
|
| GT -> prefix ^ "gt"
|
||||||
|
| LT -> prefix ^ "lt"
|
||||||
|
|
||||||
let string_of_opr = function
|
let string_of_opr = function
|
||||||
| NOT -> "not"
|
| NOT -> "not"
|
||||||
| NEG -> "neg"
|
| NEG -> "neg"
|
||||||
|
|
@ -141,85 +201,89 @@ let string_of_opr = function
|
||||||
| MUL -> "mul"
|
| MUL -> "mul"
|
||||||
| DIV -> "div"
|
| DIV -> "div"
|
||||||
| MOD -> "mod"
|
| MOD -> "mod"
|
||||||
| Cmp EQ -> "ceq"
|
| Cmp c -> string_of_cnd c ~prefix:"c"
|
||||||
| Cmp LT -> "clt"
|
|
||||||
| Cmp GT -> "cgt"
|
|
||||||
(* | Cmp NE -> "cne" *)
|
|
||||||
(* | Cmp GE -> "cge" *)
|
|
||||||
(* | Cmp LE -> "cle" *)
|
|
||||||
|
|
||||||
let pp_ins ~tbname ~label ppf = function
|
let pp_i0 ppf = function
|
||||||
|
| Ret a -> Fmt.pf ppf "ret %a" pp_arg a
|
||||||
|
|
||||||
|
let pp_i1 ppf = function
|
||||||
| Mov (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_arg b
|
| Mov (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_arg b
|
||||||
| Opr (o, a, b) -> Fmt.pf ppf "%s %a, %a" (string_of_opr o) pp_reg a pp_arg b
|
| Opr (o, a, b) -> Fmt.pf ppf "%s %a, %a" (string_of_opr o) pp_reg a pp_arg b
|
||||||
| Get (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_loc b
|
| Get (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_loc b
|
||||||
| Set (a, b) -> Fmt.pf ppf "mov %a, %a" pp_loc a pp_arg b
|
| Set (a, b) -> Fmt.pf ppf "mov %a, %a" pp_loc a pp_arg b
|
||||||
| Con (a, vtb) -> Fmt.pf ppf "con %a, %a" pp_reg a (pp_vtable ~tbname) vtb
|
|
||||||
| Loc (a, b, nam) -> Fmt.pf ppf "loc %a, %a.<%s>" pp_reg a pp_reg b nam
|
| Loc (a, b, nam) -> Fmt.pf ppf "loc %a, %a.<%s>" pp_reg a pp_reg b nam
|
||||||
| Jmp b -> Fmt.pf ppf "jmp %s" (label b)
|
| Con (a, vtb) -> Fmt.pf ppf "con %a, %a" pp_reg a pp_vtable vtb
|
||||||
| Ret a -> Fmt.pf ppf "ret %a" pp_arg a
|
| Cal (r, f, args) ->
|
||||||
| Btr (a, b1, b2) ->
|
Fmt.pf ppf "cal %a, %a(" pp_reg r pp_loc f;
|
||||||
let l1 = label b1 in
|
List.iteri (fun i a -> if i > 0 then Fmt.pf ppf ","; pp_reg ppf a) args;
|
||||||
let l2 = label b2 in
|
|
||||||
Fmt.pf ppf "btr %a, %s, %s" pp_arg a l1 l2
|
|
||||||
| Cal (a, f, args) ->
|
|
||||||
Fmt.pf ppf "cal %a, %a(" pp_reg a pp_loc f;
|
|
||||||
List.iteri (fun i d -> if i > 0 then Fmt.pf ppf ","; pp_reg ppf d) args;
|
|
||||||
Fmt.pf ppf ")"
|
Fmt.pf ppf ")"
|
||||||
|
|
||||||
let dump ?(recursive = true) println main_fn =
|
let pp_i2 ppf = function
|
||||||
let tbqueue = ref [] in
|
| IfT v -> Fmt.pf ppf "btr %a" pp_arg v
|
||||||
let tbnames = ref [] in
|
| IfC (c, a, b) ->
|
||||||
let tbname vtb =
|
let name = string_of_cnd c ~prefix:"b" in
|
||||||
try List.assq vtb !tbnames
|
Fmt.pf ppf "%s %a, %a" name pp_reg a pp_arg b
|
||||||
with Not_found ->
|
|
||||||
if recursive then tbqueue := !tbqueue @ [vtb];
|
|
||||||
let n = List.length !tbnames in
|
|
||||||
let l = Fmt.str "$tbl%d" n in
|
|
||||||
tbnames := (vtb, l) :: !tbnames; l
|
|
||||||
in
|
|
||||||
|
|
||||||
let dump_fn fn =
|
let generate_labels ep =
|
||||||
let labels = ref [ fn.entry, "ENTRY" ] in
|
let nl = ref 0 in
|
||||||
let label b =
|
let rec go t require =
|
||||||
try List.assq b !labels
|
t.preds <- t.preds + 1;
|
||||||
with Not_found ->
|
if t.label = None && (t.preds > 1 || require) then begin
|
||||||
let n = List.length !labels - 1 in
|
t.label <- Some (Fmt.str "L%d" !nl);
|
||||||
let l = Fmt.str "B%d" n in
|
incr nl
|
||||||
labels := (b, l) :: !labels; l
|
end;
|
||||||
|
if t.preds = 1 then begin
|
||||||
|
match t.edge with
|
||||||
|
| I0 _ -> ()
|
||||||
|
| I1 (_, t1) -> go t1 false
|
||||||
|
| I2 (_, t1, t2) -> go t1 false; go t2 true
|
||||||
|
end
|
||||||
|
in
|
||||||
|
ep.label <- Some "EP";
|
||||||
|
go ep false
|
||||||
|
|
||||||
|
let dump ?(margin = 8) println main =
|
||||||
|
let printf ?l fmt =
|
||||||
|
let prefix = match l with
|
||||||
|
| None -> ""
|
||||||
|
| Some l -> l ^ ":"
|
||||||
in
|
in
|
||||||
let pp_ins = pp_ins ~tbname ~label in
|
Fmt.kstr println ("%-*s" ^^ fmt) margin prefix
|
||||||
iter_blocks_df
|
|
||||||
(fun b ->
|
|
||||||
List.fold_left
|
|
||||||
(fun pfx ins ->
|
|
||||||
println (Fmt.str "%-8s%a" pfx pp_ins ins);
|
|
||||||
"")
|
|
||||||
(label b ^ ":")
|
|
||||||
(instructions b)
|
|
||||||
|> ignore)
|
|
||||||
fn.entry
|
|
||||||
in
|
in
|
||||||
|
|
||||||
println "# fun main(0)";
|
let rec pr_code t =
|
||||||
dump_fn main_fn;
|
if t.preds = 0 then
|
||||||
|
pr_jmp t
|
||||||
|
else begin
|
||||||
|
t.preds <- 0;
|
||||||
|
match t.edge with
|
||||||
|
| I0 i ->
|
||||||
|
printf ?l:t.label "%a" pp_i0 i
|
||||||
|
|
||||||
|
| I1 (i, t1) ->
|
||||||
|
printf ?l:t.label "%a" pp_i1 i;
|
||||||
|
pr_code t1
|
||||||
|
|
||||||
|
| I2 (i, t1, t2) ->
|
||||||
|
printf ?l:t.label "%a" pp_i2 i;
|
||||||
|
pr_jmp t2;
|
||||||
|
pr_code t1;
|
||||||
|
maybe_pr_code t2
|
||||||
|
end
|
||||||
|
|
||||||
|
and pr_jmp t =
|
||||||
|
printf "jmp %s" (Option.get t.label)
|
||||||
|
|
||||||
|
and maybe_pr_code t =
|
||||||
|
if t.preds > 0 then
|
||||||
|
pr_code t
|
||||||
|
|
||||||
let rec loop () =
|
|
||||||
match !tbqueue with
|
|
||||||
| [] -> ()
|
|
||||||
| vtb :: rest ->
|
|
||||||
tbqueue := rest;
|
|
||||||
Hashtbl.iter
|
|
||||||
(fun fname -> function
|
|
||||||
| Value.Field _ -> ()
|
|
||||||
| Value.Method i ->
|
|
||||||
match vtb.mthds.(i) with
|
|
||||||
| Function fn ->
|
|
||||||
println "";
|
|
||||||
println (Fmt.str "# fun %s.%s(%d)" (tbname vtb) fname fn.n_args);
|
|
||||||
dump_fn fn
|
|
||||||
| _ -> ())
|
|
||||||
vtb.elems;
|
|
||||||
loop ()
|
|
||||||
in
|
in
|
||||||
loop ()
|
|
||||||
|
|
||||||
|
let pr_funct name fn =
|
||||||
|
println (Fmt.str "# fun %s(%d)" name fn.n_args);
|
||||||
|
generate_labels fn.entry;
|
||||||
|
pr_code fn.entry
|
||||||
|
in
|
||||||
|
|
||||||
|
pr_funct "main" main
|
||||||
|
|
|
||||||
|
|
@ -57,16 +57,10 @@ module Prim = struct
|
||||||
runtime_error "call method of non-object"
|
runtime_error "call method of non-object"
|
||||||
end
|
end
|
||||||
|
|
||||||
type frame = {
|
type frame = Value.t array
|
||||||
rg : Value.t array;
|
|
||||||
mutable pc : Code.ins list;
|
|
||||||
mutable rv : Value.t;
|
|
||||||
}
|
|
||||||
|
|
||||||
let jmp fr b = fr.pc <- Code.instructions b
|
let get fr (`R a) = fr.(a)
|
||||||
|
let set fr (`R a) b = fr.(a) <- b
|
||||||
let get fr (`R a) = fr.rg.(a)
|
|
||||||
let set fr (`R a) b = fr.rg.(a) <- b
|
|
||||||
let arg fr = function
|
let arg fr = function
|
||||||
| #Code.reg as r -> get fr r
|
| #Code.reg as r -> get fr r
|
||||||
| `Cst v -> v
|
| `Cst v -> v
|
||||||
|
|
@ -87,48 +81,45 @@ let loc fr = function
|
||||||
| a, (#Code.reg as b) -> get fr a, get fr b
|
| a, (#Code.reg as b) -> get fr a, get fr b
|
||||||
| a, (`Ofs ofs) -> get fr a, Value.of_int ofs
|
| a, (`Ofs ofs) -> get fr a, Value.of_int ofs
|
||||||
|
|
||||||
let rec exec fr = function
|
let rec run fn self args =
|
||||||
| Code.Mov (a, b) -> set fr a (arg fr b)
|
let Code.{ n_args; frame_size; entry } = fn in
|
||||||
| Code.Opr (op, a, b) -> set fr a (opr op (get fr a) (arg fr b))
|
if List.length args <> n_args then
|
||||||
| Code.Get (a, bc) -> set fr a (Prim.get (loc fr bc))
|
runtime_error "wrong number of arguments, expected %d, got %d"
|
||||||
| Code.Set (bc, a) -> Prim.set (loc fr bc) (arg fr a)
|
n_args (List.length args);
|
||||||
| Code.Loc (a, b, nam) -> set fr a (Prim.loc (get fr b) nam)
|
|
||||||
| Code.Con (a, vtb) -> set fr a (Value.make_obj vtb)
|
let fr = Array.make frame_size Value.Nil in
|
||||||
| Code.Jmp bl -> jmp fr bl
|
fr.(0) <- self;
|
||||||
| Code.Btr (a, bl1, bl2) ->
|
List.iteri (fun i v -> fr.(i + 1) <- v) args;
|
||||||
jmp fr (if Value.truthy (arg fr a) then bl1 else bl2)
|
|
||||||
| Code.Ret a ->
|
step fr entry
|
||||||
fr.rv <- arg fr a
|
|
||||||
| Code.Cal (a, f, args) ->
|
and step fr t =
|
||||||
let obj, mthd = Prim.mthd (loc fr f) in
|
match t.Code.edge with
|
||||||
let args = List.map (arg fr) args in
|
| I0 (Ret a) -> arg fr a
|
||||||
set fr a (call mthd obj args)
|
|
||||||
|
| 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 =
|
and call mthd self args =
|
||||||
match mthd with
|
match mthd with
|
||||||
| Code.Function fn -> run fn self args
|
| Code.Function fn -> run fn self args
|
||||||
| _ -> Value.call mthd self args
|
| _ -> Value.call mthd self args
|
||||||
|
|
||||||
and step fr =
|
|
||||||
match fr.pc with
|
|
||||||
| [] -> ()
|
|
||||||
| i :: rest ->
|
|
||||||
fr.pc <- rest;
|
|
||||||
exec fr i;
|
|
||||||
step fr
|
|
||||||
|
|
||||||
and 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 rg = Array.make frame_size Value.Nil in
|
|
||||||
rg.(0) <- self;
|
|
||||||
List.iteri (fun i v -> rg.(i + 1) <- v) args;
|
|
||||||
|
|
||||||
let fr = { rg; pc = []; rv = Nil } in
|
|
||||||
jmp fr entry;
|
|
||||||
step fr;
|
|
||||||
fr.rv
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue