pretty print vtables (again)

bin/bcgtest.ml

@@ -0,0 +1,17 @@
+open Spice.Bcg
+open Spice.Bcg.B.Infix
+
+let () =
+  Logs.set_reporter (Logs.format_reporter ());
+  Logs.set_level (Some Logs.Debug);
+
+  let main =
+    (B.if_ (`R 1)
+       (B.mov (`R 0) (B.int 5))
+       (B.mov (`R 0) (B.int 6))
+    )
+    +> B.mul (`R 0) (B.int 2)
+    |> B.ret (`R 0)
+  in
+
+  Logs.debug (fun m -> dump (m "%s") main);

bin/dune

@@ -9,3 +9,9 @@
  (name bctest)
  (modules bctest)
  (libraries fmt logs))
+
+(executable
+ (public_name spice_bcgtest)
+ (name bcgtest)
+ (modules bcgtest)
+ (libraries spice fmt logs))

bin/main.ml

@@ -10,7 +10,7 @@ let () =
                 val one = 1
                 fun twice(x) {
                   fun f(x) (x - one) * two
-                  fun g() x + one
+                  fun g() if (x == one) two else (x + one)
                   f(g())
                 }
                 println(twice(4))

lib/compile/bcc.ml

@@ -1,25 +1,21 @@
 module Ast = Spice_syntax.Ast
-module Code = Spice_runtime.Code
 module Value = Spice_runtime.Value
+open Spice_runtime.Code
+open B.Infix
 
 exception Error of string
 
 let compile_error 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 =
   Value.Native_function
     (fun _ -> failwith "BUG: method undefined")
 
 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 set_reg id r =
     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
   in
 
-  let rec emit_exp_v sp = function
+  let rec emit_exp_v sp : Ir.exp -> B.t * arg = function
     | Ir.Lit v ->
-      `Cst v
+      B.empty, `Cst v
 
     | Ir.Var id ->
-      (get_reg id :> Code.arg)
+      B.empty, (get_reg id :> arg)
 
     | Ir.Let (id, rhs, bdy) ->
-      emit_exp_s sp rhs;
       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) ->
-      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 ->
-      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 ->
-      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) ->
-      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) ->
-      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) ->
-      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) ->
-      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) ->
       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
-      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) ->
-      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 } ->
       (* 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
       List.iteri
         (fun i (name, lambda) ->
+           let funct = compile_lambda lambda ~clos_map in
            Hashtbl.add elems name (Value.Method i);
-           mthds.(i) <- Code.Function (compile_lambda lambda ~clos_map))
+           mthds.(i) <- Function funct)
         funs;
 
       (* 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
+        bc0
 
     | Ir.Open id ->
       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"
            | Invalid_argument _ -> failwith "BUG: no captured variables"
       in
-      emit (Get (sp, (clos, ofs)))
+      B.get sp (clos, ofs)
 
     | 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 loc = sp in
-    emit (Loc (loc, obj, fld));
+    B.loc loc obj fld, (obj, (loc :> ofs))
-    obj, (loc :> Code.ofs)
 
   in
 
@@ -173,9 +165,10 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) =
       (`R 1)
       lam.args
   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)
-    entrypoint
+    ep

lib/runtime/code.ml

@@ -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 cst = [`Cst of Value.t]
@@ -10,128 +7,179 @@ 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
+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
   | Opr of opr * reg * arg
   | Get of reg * loc
   | Set of loc * arg
-  | Con of reg * vtable
+  | Con of reg * Value.vtable
   | Loc of reg * reg * string
   | 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
-  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
 
 let make_funct n_args entry =
   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
   { 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) =
   Fmt.pf ppf "R%d" i
 
 let pp_arg ppf = function
   | #reg as r -> pp_reg ppf r
-  | `Cst c -> Value.pp ppf c
+  | `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 ~tbname ppf (vtb : vtable) =
+let string_of_cnd ~prefix = function
-  Fmt.pf ppf "%s(%d){" (tbname vtb) vtb.n_slots;
+  | EQ -> prefix ^ "eq"
-  let sep = ref "" in
+  | GT -> prefix ^ "gt"
-  Hashtbl.iter
+  | LT -> prefix ^ "lt"
-    (fun name -> function
-       | Value.Method _ -> ()
-       | Value.Field idx ->
-         Fmt.pf ppf "%s%s=%d" !sep name idx;
-         sep := ",")
-    vtb.elems;
-  Fmt.pf ppf "}"
 
 let string_of_opr = function
   | NOT -> "not"
@@ -141,85 +189,127 @@ let string_of_opr = function
   | MUL -> "mul"
   | DIV -> "div"
   | 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 ~vtbname 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
-  | 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
-  | Jmp b -> Fmt.pf ppf "jmp %s" (label b)
+  | Con (a, vtb) ->
-  | Ret a -> Fmt.pf ppf "ret %a" pp_arg a
+    Fmt.pf ppf "con %a, %s(%d){" pp_reg a (vtbname vtb) vtb.n_slots;
-  | Btr (a, b1, b2) ->
+    let sep = ref "" in
-    let l1 = label b1 in
+    Hashtbl.iter
-    let l2 = label b2 in
+      (fun name -> function
-    Fmt.pf ppf "btr %a, %s, %s" pp_arg a l1 l2
+         | Value.Method _ -> ()
-  | Cal (a, f, args) ->
+         | Value.Field idx ->
-    Fmt.pf ppf "cal %a, %a(" pp_reg a pp_loc f;
+           Fmt.pf ppf "%s%s=%d" !sep name idx;
-    List.iteri (fun i d -> if i > 0 then Fmt.pf ppf ","; pp_reg ppf d) args;
+           sep := ",")
+      vtb.elems;
+    Fmt.pf ppf "}"
+  | 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 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
+
+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 ?(recursive = true) ?(margin = 8) println main =
+  let vtbnames = ref [] in
+  let vtbqueue = ref [] in
+  let vtbname vtb = try List.assq vtb !vtbnames
     with Not_found ->
-      if recursive then tbqueue := !tbqueue @ [vtb];
+      let name = Fmt.str "$tb%d" (List.length !vtbnames) in
-      let n = List.length !tbnames in
+      vtbnames := (vtb, name) :: !vtbnames;
-      let l = Fmt.str "$tbl%d" n in
+      vtbqueue := !vtbqueue @ [vtb];
-      tbnames := (vtb, l) :: !tbnames; l
+      name
   in
 
-  let dump_fn fn =
+  let printf ?l fmt =
-    let labels = ref [ fn.entry, "ENTRY" ] in
+    let prefix = match l with
-    let label b =
+      | None -> ""
-      try List.assq b !labels
+      | Some l -> l ^ ":"
-      with Not_found ->
-        let n = List.length !labels - 1 in
-        let l = Fmt.str "B%d" n in
-        labels := (b, l) :: !labels; l
     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
 
-  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
 
-  let rec loop () =
+      | I1 (i, t1) ->
-    match !tbqueue with
+        printf ?l:t.label "%a" (pp_i1 ~vtbname) i;
-    | [] -> ()
+        pr_code t1
-    | vtb :: rest ->
+
-      tbqueue := rest;
+      | I2 (i, t1, t2) ->
-      Hashtbl.iter
+        printf ?l:t.label "%a" pp_i2 i;
-        (fun fname -> function
+        pr_jmp t2;
-           | Value.Field _ -> ()
+        pr_code t1;
-           | Value.Method i ->
+        maybe_pr_code t2
-             match vtb.mthds.(i) with
+    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
+  in
+
+  let pr_funct name fn =
+    println (Fmt.str "# fun %s(%d)" name fn.n_args);
+    generate_labels fn.entry;
+    pr_code fn.entry;
+    println ""
+  in
+
+  let pr_vtable (vtb : Value.vtable) =
+    let vnam = vtbname vtb in
+    Hashtbl.iter
+      (fun fnam -> function
+         | Value.Method i ->
+           begin match vtb.mthds.(i) with
              | Function fn ->
-               println "";
+               pr_funct (Fmt.str "%s.%s" vnam fnam) fn
-               println (Fmt.str "# fun %s.%s(%d)" (tbname vtb) fname fn.n_args);
+             | _ -> ()
-               dump_fn fn
+           end
-             | _ -> ())
+         | _ -> ())
-        vtb.elems;
+      vtb.elems
-      loop ()
   in
-  loop ()
 
+  pr_funct "main" main;
+  while recursive && !vtbqueue <> [] do
+    pr_vtable (List.hd !vtbqueue);
+    vtbqueue := List.tl !vtbqueue
+  done

lib/runtime/interp.ml

@@ -57,16 +57,10 @@ module Prim = struct
       runtime_error "call method of non-object"
 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
   | #Code.reg as r -> get fr r
   | `Cst v -> v
@@ -87,48 +81,45 @@ 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 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 =
   match mthd with
   | Code.Function fn -> run fn 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
-