From d66b336435c15dc1241088943c9f85c54ca53f2a Mon Sep 17 00:00:00 2001 From: tali Date: Thu, 21 Dec 2023 18:13:26 -0500 Subject: [PATCH] rework the interpreted bc to resemble the prospective actual bc --- lib/compile/bcc.ml | 127 +++++++++++++++++++------------------ lib/runtime/code.ml | 144 +++++++++++++++++++++++------------------- lib/runtime/interp.ml | 78 +++++++++++++---------- 3 files changed, 190 insertions(+), 159 deletions(-) diff --git a/lib/compile/bcc.ml b/lib/compile/bcc.ml index 467defc..de7f737 100644 --- a/lib/compile/bcc.ml +++ b/lib/compile/bcc.ml @@ -7,7 +7,7 @@ exception Error of string let compile_error f = Fmt.kstr (fun msg -> raise (Error msg)) f -let off (Code.R i) k = Code.R (i + k) +let off (`R i) k = `R (i + k) let suc r = off r 1 let undef_method = @@ -31,87 +31,90 @@ 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 sp = function + let rec emit_exp_v sp = function + | Ir.Lit v -> + `Cst v + | Ir.Var id -> - get_reg id + (get_reg id :> Code.arg) | Ir.Let (id, rhs, bdy) -> emit_exp_s sp rhs; set_reg id sp; - emit_exp (suc sp) bdy + emit_exp_v (suc sp) bdy | Ir.Seq (e1, e2) -> - emit_exp sp e1 |> ignore; - emit_exp sp e2 + emit_exp_v sp e1 |> ignore; + emit_exp_v sp e2 | ir -> emit_exp_s sp ir; - sp - - and emit_exp_s sp = function - | Ir.Lit im -> - emit (LDI (sp, im)) + (sp :> Code.arg) + and emit_exp_s sp : Ir.exp -> unit = function | Ir.Get path -> - let obj, loc = emit_path sp path in - emit (GET (sp, obj, loc)) + let loc = emit_path sp path in + emit (Get (sp, loc)) | Ir.Set (path, rhs) -> - let obj, loc = emit_path sp path in - let rv = emit_exp (suc sp) rhs in - emit (SET (rv, obj, loc)) + let loc = emit_path sp path in + let rv = emit_exp_v (suc sp) rhs in + emit (Set (loc, rv)) | Ir.Seq (e1, e2) -> - emit_exp sp e1 |> ignore; + emit_exp_v sp e1 |> ignore; emit_exp_s sp e2 | 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 sp e0 in - emit (CBR (c, b1, b2)); - enter b1; emit_exp_s sp e1; emit (JMP b3); - enter b2; emit_exp_s sp e2; emit (JMP b3); + 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 | Ir.Uop (op, e1) -> - let r1 = emit_exp sp e1 in - emit (match op with - | Not -> NOT (sp, r1)) + let v1 = emit_exp_v sp e1 in + let op = match op with Not -> Code.NOT in + emit (Opr (op, sp, v1)) | Ir.Bop (op, e1, e2) -> - let r1 = emit_exp sp e1 in - let r2 = emit_exp (suc sp) e2 in - emit (match op with - | Add -> ADD (sp, r1, r2) - | Sub -> SUB (sp, r1, r2) - | Mul -> MUL (sp, r1, r2) - | Div -> failwith "Bcc.compile_exp: TODO(Bop(Div))" - | Mod -> failwith "Bcc.compile_exp: TODO(Bop(Mod))" - | Eql -> EQL (sp, r1, r2) - | Grt -> GRT (sp, r1, r2) - | Lst -> LST (sp, r1, r2)) + 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 + in + emit_exp_s sp e1; + let v2 = emit_exp_v (suc sp) e2 in + emit (Opr (op, sp, v2)) | Ir.Call (fn, args) -> - let obj, mth = emit_path sp fn in - let args = - List.mapi - (fun i arg -> - let rv = off mth (i + 1) in - emit_exp_s rv arg; rv) + 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, obj, mth, args)) + emit (Cal (sp, fn, List.rev args_r)) | Ir.Obj { vals; funs; clos } -> (* assign each captured id to a slot *) let clos_map = Hashtbl.create 64 in let n_slots = List.fold_left - (fun n id -> - Hashtbl.add clos_map id n; - n + 1) + (fun ofs id -> + Hashtbl.add clos_map id (`Ofs ofs); + ofs + 1) (List.length vals) clos in @@ -132,46 +135,46 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) = funs; (* construct object and save captured id's *) - emit (CON (sp, { n_slots; elems; mthds })); + let vtb : Code.vtable = { n_slots; elems; mthds } in + emit (Con (sp, vtb)); Hashtbl.iter - (fun id idx -> - let obj = sp in - let loc = suc sp in - emit (LDI (loc, Value.of_int idx)); - emit (SET (get_reg id, obj, loc))) + (fun cap_id clos_ofs -> + let cap_v = (get_reg cap_id :> Code.arg) in + emit (Set ((sp, clos_ofs), cap_v))) clos_map | Ir.Open id -> - let idx = try Hashtbl.find (Option.get clos_map) id + let clos = get_reg lam.self in + let ofs = try Hashtbl.find (Option.get clos_map) id with Not_found -> failwith "BUG: %S not captured" | Invalid_argument _ -> failwith "BUG: no captured variables" in - emit (LDI (sp, Value.of_int idx)); - emit (GET (sp, get_reg lam.self, sp)) + emit (Get (sp, (clos, ofs))) | ir -> - let rv = emit_exp sp ir in - if rv <> sp then emit (LDR (sp, rv)) + let rv = emit_exp_v sp ir in + if rv <> (sp :> Code.arg) then + emit (Mov (sp, rv)) and emit_path sp (obj, fld) = let obj = get_reg obj in let loc = sp in - emit (LOC (loc, obj, fld)); - obj, loc + emit (Loc (loc, obj, fld)); + obj, (loc :> Code.ofs) in (* R0 = self *) (* R(i+1) = args[i] *) - set_reg lam.self (Code.R 0); + set_reg lam.self (`R 0); let sp = List.fold_left (fun sp arg -> set_reg arg sp; suc sp) - (Code.R 1) + (`R 1) lam.args in - let rv = emit_exp sp lam.body in - emit (RET rv); + let rv = emit_exp_v sp lam.body in + emit (Ret rv); Code.make_funct (List.length lam.args) diff --git a/lib/runtime/code.ml b/lib/runtime/code.ml index c791448..19e0859 100644 --- a/lib/runtime/code.ml +++ b/lib/runtime/code.ml @@ -3,53 +3,50 @@ module Ast = Spice_syntax.Ast type imm = Value.t type vtable = Value.vtable -type reg = R of int [@@unboxed] +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 +(* and cnd = EQ | NE | LT | GE | GT | LE *) type ins = - (* registers *) - | LDI of reg * imm - | LDR of reg * reg - (* arithmetic *) - | ADD of reg * reg * reg - | SUB of reg * reg * reg - | MUL of reg * reg * reg - (* comparison *) - | LST of reg * reg * reg - | GRT of reg * reg * reg - | EQL of reg * reg * reg - | NOT of reg * reg - (* objects *) - | GET of reg * reg * reg - | SET of reg * reg * reg - | LOC of reg * reg * string - | CON of reg * vtable - | CAL of reg * reg * reg * reg list - (* control flow *) - | RET of reg - | JMP of block - | CBR of reg * block * block + | 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 + | Btr of arg * block * block + | Jmp of block + | Ret of arg and block = { mutable ins_list_rev : ins list } +let arg_regs = function + | #reg as r -> [r] + | #cst -> [] + +let loc_regs = function + | (r1, (#reg as r2)) -> [r1; r2] + | (r1, #ofs) -> [r1] + let registers = function - | JMP _ -> [] - | RET r - | LDI (r, _) - | CON (r, _) - | CBR (r, _, _) -> [r] - | LDR (r1, r2) - | NOT (r1, r2) - | LOC (r1, r2, _) -> [r1; r2] - | ADD (r1, r2, r3) - | SUB (r1, r2, r3) - | MUL (r1, r2, r3) - | LST (r1, r2, r3) - | GRT (r1, r2, r3) - | EQL (r1, r2, r3) - | GET (r1, r2, r3) - | SET (r1, r2, r3) -> [r1; r2; r3] - | CAL (r1, r2, r3, rs) -> r1::r2::r3::rs + | 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 _ -> [] let make_block () = { ins_list_rev = [] } @@ -78,8 +75,8 @@ let iter_blocks_df f b0 = the whole list is pointless. but just to be safe ... *) List.iter (function - | JMP b1 -> enqueue b1 - | CBR (_, b1, b2) -> enqueue b1; enqueue b2 + | Jmp b1 -> enqueue b1 + | Btr (_, b1, b2) -> enqueue b1; enqueue b2 | _ -> ()) b.ins_list_rev; loop () @@ -103,7 +100,7 @@ let make_funct n_args entry = fsize := List.rev_map registers b.ins_list_rev |> List.flatten - |> List.fold_left (fun fs (R i) -> max fs (i + 1)) + |> List.fold_left (fun fs (`R i) -> max fs (i + 1)) !fsize) entry; !fsize @@ -113,7 +110,16 @@ let make_funct n_args entry = (* pretty printing *) -let pp_reg ppf (R i) = Fmt.pf ppf "R%d" i +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 + +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; @@ -127,30 +133,38 @@ let pp_vtable ~tbname ppf (vtb : vtable) = vtb.elems; Fmt.pf ppf "}" +let string_of_opr = function + | NOT -> "not" + | NEG -> "neg" + | ADD -> "add" + | SUB -> "sub" + | MUL -> "mul" + | DIV -> "div" + | MOD -> "mod" + | Cmp EQ -> "ceq" + | Cmp LT -> "clt" + | Cmp GT -> "cgt" + (* | Cmp NE -> "cne" *) + (* | Cmp GE -> "cge" *) + (* | Cmp LE -> "cle" *) + let pp_ins ~tbname ~label ppf = function - | LDI (a, b) -> Fmt.pf ppf "mov %a, %s" pp_reg a (Value.to_string b) - | LDR (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_reg b - | ADD (a, b, c) -> Fmt.pf ppf "add %a, %a, %a" pp_reg a pp_reg b pp_reg c - | SUB (a, b, c) -> Fmt.pf ppf "sub %a, %a, %a" pp_reg a pp_reg b pp_reg c - | MUL (a, b, c) -> Fmt.pf ppf "mul %a, %a, %a" pp_reg a pp_reg b pp_reg c - | LST (a, b, c) -> Fmt.pf ppf "lst %a, %a, %a" pp_reg a pp_reg b pp_reg c - | GRT (a, b, c) -> Fmt.pf ppf "grt %a, %a, %a" pp_reg a pp_reg b pp_reg c - | EQL (a, b, c) -> Fmt.pf ppf "eql %a, %a, %a" pp_reg a pp_reg b pp_reg c - | NOT (a, b) -> Fmt.pf ppf "not %a, %a" pp_reg a pp_reg b - | GET (a, b, c) -> Fmt.pf ppf "mov %a, %a[%a]" pp_reg a pp_reg b pp_reg c - | SET (a, b, c) -> Fmt.pf ppf "mov %a[%a], %a" pp_reg b pp_reg c pp_reg a - | LOC (a, b, el) -> Fmt.pf ppf "loc %a, %a.%s" pp_reg a pp_reg b el - | CON (a, vt) -> Fmt.pf ppf "con %a, %a" pp_reg a (pp_vtable ~tbname) vt - | CAL (a, b, c, ds) -> - Fmt.pf ppf "cal %a, %a[%a](" pp_reg a pp_reg b pp_reg c; - List.iteri (fun i d -> if i > 0 then Fmt.pf ppf ","; pp_reg ppf d) ds; - Fmt.pf ppf ")" - | RET a -> Fmt.pf ppf "ret %a" pp_reg a - | JMP b -> Fmt.pf ppf "jmp %s" (label b) - | CBR (a, b1, b2) -> + | 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 "cbr %a, %s, %s" pp_reg a l1 l2 + 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 ")" let dump ?(recursive = true) println main_fn = let tbqueue = ref [] in diff --git a/lib/runtime/interp.ml b/lib/runtime/interp.ml index a8b46b3..149a8e2 100644 --- a/lib/runtime/interp.ml +++ b/lib/runtime/interp.ml @@ -33,21 +33,21 @@ module Prim = struct with Not_found -> runtime_error "no such element %S" name - let get obj loc = + 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 = + 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 = + 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" @@ -58,37 +58,51 @@ module Prim = struct end type frame = { - r : 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 rec exec ({ r; _ } as fr) = function - | Code.LDI (R a, v) -> r.(a) <- v - | Code.LDR (R a, R b) -> r.(a) <- r.(b) - | Code.ADD (R a, R b, R c) -> r.(a) <- Prim.add r.(b) r.(c) - | Code.SUB (R a, R b, R c) -> r.(a) <- Prim.sub r.(b) r.(c) - | Code.MUL (R a, R b, R c) -> r.(a) <- Prim.mul r.(b) r.(c) - | Code.LST (R a, R b, R c) -> r.(a) <- Prim.lst r.(b) r.(c) - | Code.GRT (R a, R b, R c) -> r.(a) <- Prim.grt r.(b) r.(c) - | Code.NOT (R a, R b) -> r.(a) <- Prim.not r.(b) - | Code.EQL (R a, R b, R c) -> r.(a) <- Prim.eql r.(b) r.(c) - | Code.GET (R a, R b, R c) -> r.(a) <- Prim.get r.(b) r.(c) - | Code.SET (R a, R b, R c) -> Prim.set r.(b) r.(c) r.(a) - | Code.LOC (R a, R b, el) -> r.(a) <- Prim.loc r.(b) el - | Code.CON (R a, vtbl) -> r.(a) <- Value.make_obj vtbl - | Code.CAL (R a, R b, R c, args) -> - let obj, mthd = Prim.mthd r.(b) r.(c) in - let args = List.map (fun (Code.R i) -> r.(i)) args in - r.(a) <- call mthd obj args - | Code.JMP b -> jmp fr b - | Code.CBR (R a, b1, b2) -> - jmp fr (if Value.truthy r.(a) then b1 else b2) - | Code.RET (R a) -> - fr.rv <- r.(a); - fr.pc <- [] +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 + +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 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) and call mthd self args = match mthd with @@ -109,11 +123,11 @@ and run fn self args = runtime_error "wrong number of arguments, expected %d, got %d" n_args (List.length args); - let r = Array.make frame_size Value.Nil in - r.(0) <- self; - List.iteri (fun i v -> r.(i + 1) <- v) 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 = { r; pc = []; rv = Nil } in + let fr = { rg; pc = []; rv = Nil } in jmp fr entry; step fr; fr.rv