From f3954e6ca5cff5273c98a39c2fee95bcd3d479f5 Mon Sep 17 00:00:00 2001 From: tali Date: Sat, 23 Dec 2023 14:12:35 -0500 Subject: [PATCH] refactor interpreter to use bytecode graph --- lib/compile/bcc.ml | 143 ++++++++--------- lib/compile/bcg.ml | 228 --------------------------- lib/runtime/code.ml | 356 +++++++++++++++++++++++++----------------- lib/runtime/interp.ml | 87 +++++------ 4 files changed, 317 insertions(+), 497 deletions(-) delete mode 100644 lib/compile/bcg.ml diff --git a/lib/compile/bcc.ml b/lib/compile/bcc.ml index de7f737..7a1c5a9 100644 --- a/lib/compile/bcc.ml +++ b/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 suc r = off r 1 +let add (`R i) k = `R (i + k) +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; - emit_exp_v sp e2 + let bc1, _ = emit_exp_v sp e1 in + let bc2, v = emit_exp_v sp e2 in + (bc1 +> bc2), v | ir -> - emit_exp_s sp ir; - (sp :> Code.arg) + emit_exp_s sp ir, (sp :> 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 - emit (Get (sp, loc)) + let bc1, loc = emit_path sp path in + bc1 +> B.get sp loc | Ir.Set (path, rhs) -> - let loc = emit_path sp path in - let rv = emit_exp_v (suc sp) rhs in - emit (Set (loc, rv)) + let bc1, loc = emit_path sp path in + let bc2, rv = emit_exp_v (suc sp) rhs in + bc1 +> bc2 +> B.set loc rv | Ir.Seq (e1, e2) -> - emit_exp_v sp e1 |> ignore; - emit_exp_s sp e2 + let bc1, _ = emit_exp_v sp e1 in + let bc2 = emit_exp_s sp e2 in + bc1 +> bc2 | Ir.If (e0, e1, e2) -> - let b1 = Code.make_block () in - let b2 = Code.make_block () in - let b3 = Code.make_block () in - let c = emit_exp_v sp e0 in - 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 + let bc0, v0 = emit_exp_v sp e0 in + let bc1 = emit_exp_s sp e1 in + let bc2 = emit_exp_s sp e2 in + bc0 +> B.if_ v0 bc1 bc2 | Ir.Uop (op, e1) -> - let v1 = emit_exp_v sp e1 in - let op = match op with Not -> Code.NOT in - emit (Opr (op, sp, v1)) + let op = match op with Not -> B.not_ in + let bc1, v1 = emit_exp_v sp e1 in + bc1 +> op sp v1 | Ir.Bop (op, e1, e2) -> let op = match op with - | Add -> Code.ADD - | Sub -> Code.SUB - | Mul -> Code.MUL - | Div -> Code.DIV - | Mod -> Code.MOD - | Eql -> Code.Cmp EQ - | Grt -> Code.Cmp GT - | Lst -> Code.Cmp LT + | Add -> B.add + | Sub -> B.sub + | Mul -> B.mul + | Div -> B.div + | Mod -> B.mod_ + | Eql -> B.ceq + | Grt -> B.cgt + | Lst -> B.clt in - emit_exp_s sp e1; - let v2 = emit_exp_v (suc sp) e2 in - emit (Opr (op, sp, v2)) + let bc1 = emit_exp_s sp e1 in + let bc2, v2 = emit_exp_v (suc sp) e2 in + bc1 +> bc2 +> op sp v2 | Ir.Call (fn, args) -> - let fn = emit_path sp fn in - let args_r, _ = - List.fold_left - (fun (args, sp) arg -> - emit_exp_s sp arg; - sp :: args, suc sp) - ([], suc sp) - args - in - emit (Cal (sp, fn, List.rev args_r)) + let bc0, fn = emit_path sp fn in + let argvs = List.mapi (fun i _ -> add sp (i + 1)) args in + let bc1 = B.concat (List.map2 emit_exp_s argvs args) in + bc0 +> bc1 +> B.cal sp fn argvs | 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 - emit (Con (sp, vtb)); - Hashtbl.iter - (fun cap_id clos_ofs -> - let cap_v = (get_reg cap_id :> Code.arg) in - emit (Set ((sp, clos_ofs), cap_v))) + let bc0 = B.con sp { n_slots; mthds; elems } in + (* Hashtbl.iter *) + (* clos_map *) + Hashtbl.fold + (fun cap_id clos_ofs bc -> + 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 - if rv <> (sp :> Code.arg) then - emit (Mov (sp, rv)) + let bc, rv = emit_exp_v sp ir in + if rv = (sp :> arg) then + 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)); - obj, (loc :> Code.ofs) + B.loc loc obj fld, (obj, (loc :> 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 diff --git a/lib/compile/bcg.ml b/lib/compile/bcg.ml deleted file mode 100644 index 6434036..0000000 --- a/lib/compile/bcg.ml +++ /dev/null @@ -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 diff --git a/lib/runtime/code.ml b/lib/runtime/code.ml index 19e0859..8ec4e23 100644 --- a/lib/runtime/code.ml +++ b/lib/runtime/code.ml @@ -1,7 +1,4 @@ -module Ast = Spice_syntax.Ast - -type imm = Value.t -type vtable = Value.vtable +(* instruction operand types, etc. *) type reg = [`R of int] type cst = [`Cst of Value.t] @@ -10,119 +7,177 @@ 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 | NE | LT | GE | GT | LE *) +and cnd = EQ | LT | GT (* | NE | LE | GE *) -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 = - { mutable ins_list_rev : ins list } +type i2 = + | IfT of arg + | IfC of cnd * reg * arg -let arg_regs = function - | #reg as r -> [r] - | #cst -> [] +(* bytecode graph nodes *) -let loc_regs = function - | (r1, (#reg as r2)) -> [r1; r2] - | (r1, #ofs) -> [r1] +type t = { + mutable edge : edge; + mutable label : string option; + mutable preds : int; +} -let registers = function - | Ret v - | Btr (v, _, _) -> arg_regs v - | Mov (r, v) - | 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 _ -> [] +and edge = + | I0 of i0 + | I1 of i1 * t + | I2 of i2 * t * t -let make_block () = - { ins_list_rev = [] } +let make edge = { + edge; + label = None; + preds = 0; +} -let extend b ins = - b.ins_list_rev <- ins :: b.ins_list_rev +let sucs = function + | I0 _ -> [] + | I1 (_, t) -> [t] + | I2 (_, t1, t2) -> [t1; t2] -let instructions b = - List.rev b.ins_list_rev +let registers e = + 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 queue = ref [ b0 ] in - let visited = ref !queue in - let enqueue b = - if not (List.memq b !visited) then ( - queue := !queue @ [b]; - visited := b :: !visited) +let preorder t0 = + let rec go t = + t.preds <- t.preds + 1; + if t.preds = 1 then + t :: List.flatten (List.map go (sucs t.edge)) + else + [] in - let rec loop () = - 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 () + List.map (fun t -> t.preds <- 0; t) (go t0) +(* functions *) -type funct = - { n_args : int; - frame_size : int; - entry : block } +type funct = { + n_args : int; + frame_size : int; + 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 - iter_blocks_df - (fun b -> - fsize := - List.rev_map registers b.ins_list_rev - |> List.flatten - |> List.fold_left (fun fs (`R i) -> max fs (i + 1)) - !fsize) - entry; - !fsize + List.map (fun t -> registers t.edge) (preorder entry) + |> List.flatten + |> List.fold_left + (fun fs (`R i) -> max fs (i + 1)) + (n_args + 1) 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) = - Fmt.pf ppf "%s(%d){" (tbname vtb) vtb.n_slots; +let pp_vtable ppf (vtb : Value.vtable) = + Fmt.pf ppf "(%d){" vtb.n_slots; let sep = ref "" in Hashtbl.iter (fun name -> function @@ -133,6 +188,11 @@ let pp_vtable ~tbname ppf (vtb : vtable) = vtb.elems; 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" @@ -141,85 +201,89 @@ let string_of_opr = function | MUL -> "mul" | DIV -> "div" | MOD -> "mod" - | Cmp EQ -> "ceq" - | Cmp LT -> "clt" - | Cmp GT -> "cgt" - (* | Cmp NE -> "cne" *) - (* | Cmp GE -> "cge" *) - (* | Cmp LE -> "cle" *) + | Cmp c -> string_of_cnd c ~prefix:"c" -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 | 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) - | Ret a -> Fmt.pf ppf "ret %a" pp_arg a - | Btr (a, b1, b2) -> - let l1 = label b1 in - 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; + | 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 dump ?(recursive = true) println main_fn = - let tbqueue = ref [] in - let tbnames = ref [] in - let tbname vtb = - try List.assq vtb !tbnames - 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 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 dump_fn fn = - let labels = ref [ fn.entry, "ENTRY" ] in - let label b = - try List.assq b !labels - with Not_found -> - let n = List.length !labels - 1 in - let l = Fmt.str "B%d" n in - labels := (b, l) :: !labels; l +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 ?(margin = 8) println main = + let printf ?l fmt = + let prefix = match l with + | None -> "" + | Some l -> l ^ ":" in - let pp_ins = pp_ins ~tbname ~label in - 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 + Fmt.kstr println ("%-*s" ^^ fmt) margin prefix in - println "# fun main(0)"; - dump_fn main_fn; + let rec pr_code 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_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 - 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 diff --git a/lib/runtime/interp.ml b/lib/runtime/interp.ml index 149a8e2..da33b11 100644 --- a/lib/runtime/interp.ml +++ b/lib/runtime/interp.ml @@ -57,16 +57,10 @@ module Prim = struct runtime_error "call method of non-object" end -type frame = { - rg : Value.t array; - mutable pc : Code.ins list; - mutable rv : Value.t; -} +type frame = Value.t array -let jmp fr b = fr.pc <- Code.instructions b - -let get fr (`R a) = fr.rg.(a) -let set fr (`R a) b = fr.rg.(a) <- b +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 @@ -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 - | Code.Mov (a, b) -> set fr a (arg fr b) - | Code.Opr (op, a, b) -> set fr a (opr op (get fr a) (arg fr b)) - | Code.Get (a, bc) -> set fr a (Prim.get (loc fr bc)) - | Code.Set (bc, a) -> Prim.set (loc fr bc) (arg fr a) - | 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) - | Code.Jmp bl -> jmp fr bl - | Code.Btr (a, bl1, bl2) -> - jmp fr (if Value.truthy (arg fr a) then bl1 else bl2) - | Code.Ret a -> - fr.rv <- arg fr a - | Code.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) +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 -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 -