iitalics
/
spice
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rework the interpreted bc to resemble the prospective actual bc

This commit is contained in:
tali 2023-12-21 18:13:26 -05:00
parent 12a519cfd7
commit d66b336435
3 changed files with 190 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
lib/compile/bcc.ml
View File

@ -7,7 +7,7 @@ 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 (Code.R i) k = Code.R (i + k) let off (`R i) k = `R (i + k)
let suc r = off r 1 let suc r = off r 1
let undef_method = 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 Not_found -> Fmt.failwith "BUG: '%a' unassigned" Ir.pp_id id
in in
let rec emit_exp sp = function let rec emit_exp_v sp = function
| Ir.Lit v ->
`Cst v
| Ir.Var id -> | Ir.Var id ->
get_reg id (get_reg id :> Code.arg)
| Ir.Let (id, rhs, bdy) -> | Ir.Let (id, rhs, bdy) ->
emit_exp_s sp rhs; emit_exp_s sp rhs;
set_reg id sp; set_reg id sp;
emit_exp (suc sp) bdy emit_exp_v (suc sp) bdy
| Ir.Seq (e1, e2) -> | Ir.Seq (e1, e2) ->
emit_exp sp e1 |> ignore; emit_exp_v sp e1 |> ignore;
emit_exp sp e2 emit_exp_v sp e2
| ir -> | ir ->
emit_exp_s sp ir; emit_exp_s sp ir;
sp (sp :> Code.arg)
and emit_exp_s sp = function
| Ir.Lit im ->
emit (LDI (sp, im))
and emit_exp_s sp : Ir.exp -> unit = function
| Ir.Get path -> | Ir.Get path ->
let obj, loc = emit_path sp path in let loc = emit_path sp path in
emit (GET (sp, obj, loc)) emit (Get (sp, loc))
| Ir.Set (path, rhs) -> | Ir.Set (path, rhs) ->
let obj, loc = emit_path sp path in let loc = emit_path sp path in
let rv = emit_exp (suc sp) rhs in let rv = emit_exp_v (suc sp) rhs in
emit (SET (rv, obj, loc)) emit (Set (loc, rv))
| Ir.Seq (e1, e2) -> | Ir.Seq (e1, e2) ->
emit_exp sp e1 |> ignore; emit_exp_v sp e1 |> ignore;
emit_exp_s sp e2 emit_exp_s sp e2
| Ir.If (e0, e1, e2) -> | Ir.If (e0, e1, e2) ->
let b1 = Code.make_block () in let b1 = Code.make_block () in
let b2 = Code.make_block () in let b2 = Code.make_block () in
let b3 = Code.make_block () in let b3 = Code.make_block () in
let c = emit_exp sp e0 in let c = emit_exp_v sp e0 in
emit (CBR (c, b1, b2)); emit (Btr (c, b1, b2));
enter b1; emit_exp_s sp e1; emit (JMP b3); enter b1; emit_exp_s sp e1; emit (Jmp b3);
enter b2; emit_exp_s sp e2; emit (JMP b3); enter b2; emit_exp_s sp e2; emit (Jmp b3);
enter b3 enter b3
| Ir.Uop (op, e1) -> | Ir.Uop (op, e1) ->
let r1 = emit_exp sp e1 in let v1 = emit_exp_v sp e1 in
emit (match op with let op = match op with Not -> Code.NOT in
| Not -> NOT (sp, r1)) emit (Opr (op, sp, v1))
| Ir.Bop (op, e1, e2) -> | Ir.Bop (op, e1, e2) ->
let r1 = emit_exp sp e1 in let op = match op with
let r2 = emit_exp (suc sp) e2 in | Add -> Code.ADD
emit (match op with | Sub -> Code.SUB
| Add -> ADD (sp, r1, r2) | Mul -> Code.MUL
| Sub -> SUB (sp, r1, r2) | Div -> Code.DIV
| Mul -> MUL (sp, r1, r2) | Mod -> Code.MOD
| Div -> failwith "Bcc.compile_exp: TODO(Bop(Div))" | Eql -> Code.Cmp EQ
| Mod -> failwith "Bcc.compile_exp: TODO(Bop(Mod))" | Grt -> Code.Cmp GT
| Eql -> EQL (sp, r1, r2) | Lst -> Code.Cmp LT
| Grt -> GRT (sp, r1, r2) in
| Lst -> LST (sp, r1, r2)) emit_exp_s sp e1;
let v2 = emit_exp_v (suc sp) e2 in
emit (Opr (op, sp, v2))
| Ir.Call (fn, args) -> | Ir.Call (fn, args) ->
let obj, mth = emit_path sp fn in let fn = emit_path sp fn in
let args = let args_r, _ =
List.mapi List.fold_left
(fun i arg -> (fun (args, sp) arg ->
let rv = off mth (i + 1) in emit_exp_s sp arg;
emit_exp_s rv arg; rv) sp :: args, suc sp)
([], suc sp)
args args
in in
emit (CAL (sp, obj, mth, args)) 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 *)
let clos_map = Hashtbl.create 64 in let clos_map = Hashtbl.create 64 in
let n_slots = let n_slots =
List.fold_left List.fold_left
(fun n id -> (fun ofs id ->
Hashtbl.add clos_map id n; Hashtbl.add clos_map id (`Ofs ofs);
n + 1) ofs + 1)
(List.length vals) (List.length vals)
clos clos
in in
@ -132,46 +135,46 @@ let rec compile_lambda ?clos_map (lam : Ir.lambda) =
funs; funs;
(* construct object and save captured id's *) (* 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 Hashtbl.iter
(fun id idx -> (fun cap_id clos_ofs ->
let obj = sp in let cap_v = (get_reg cap_id :> Code.arg) in
let loc = suc sp in emit (Set ((sp, clos_ofs), cap_v)))
emit (LDI (loc, Value.of_int idx));
emit (SET (get_reg id, obj, loc)))
clos_map clos_map
| Ir.Open id -> | 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" 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 (LDI (sp, Value.of_int idx)); emit (Get (sp, (clos, ofs)))
emit (GET (sp, get_reg lam.self, sp))
| ir -> | ir ->
let rv = emit_exp sp ir in let rv = emit_exp_v sp ir in
if rv <> sp then emit (LDR (sp, rv)) if rv <> (sp :> Code.arg) then
emit (Mov (sp, rv))
and emit_path sp (obj, fld) = and emit_path sp (obj, fld) =
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)); emit (Loc (loc, obj, fld));
obj, loc obj, (loc :> Code.ofs)
in in
(* R0 = self *) (* R0 = self *)
(* R(i+1) = args[i] *) (* R(i+1) = args[i] *)
set_reg lam.self (Code.R 0); set_reg lam.self (`R 0);
let sp = let sp =
List.fold_left List.fold_left
(fun sp arg -> set_reg arg sp; suc sp) (fun sp arg -> set_reg arg sp; suc sp)
(Code.R 1) (`R 1)
lam.args lam.args
in in
let rv = emit_exp sp lam.body in let rv = emit_exp_v sp lam.body in
emit (RET rv); emit (Ret rv);
Code.make_funct Code.make_funct
(List.length lam.args) (List.length lam.args)

144
lib/runtime/code.ml
View File

@ -3,53 +3,50 @@ module Ast = Spice_syntax.Ast
type imm = Value.t type imm = Value.t
type vtable = Value.vtable 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 = type ins =
(* registers *) | Mov of reg * arg
| LDI of reg * imm | Opr of opr * reg * arg
| LDR of reg * reg | Get of reg * loc
(* arithmetic *) | Set of loc * arg
| ADD of reg * reg * reg | Con of reg * vtable
| SUB of reg * reg * reg | Loc of reg * reg * string
| MUL of reg * reg * reg | Cal of reg * loc * reg list
(* comparison *) | Btr of arg * block * block
| LST of reg * reg * reg | Jmp of block
| GRT of reg * reg * reg | Ret of arg
| 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
and block = and block =
{ mutable ins_list_rev : ins list } { 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 let registers = function
| JMP _ -> [] | Ret v
| RET r | Btr (v, _, _) -> arg_regs v
| LDI (r, _) | Mov (r, v)
| CON (r, _) | Opr (_, r, v) -> r :: arg_regs v
| CBR (r, _, _) -> [r] | Get (r, l) -> r :: loc_regs l
| LDR (r1, r2) | Set (l, v) -> arg_regs v @ loc_regs l
| NOT (r1, r2) | Con (r, _) -> [r]
| LOC (r1, r2, _) -> [r1; r2] | Loc (r1, r2, _) -> [r1; r2]
| ADD (r1, r2, r3) | Cal (r, l, rs) -> loc_regs l @ r :: rs
| SUB (r1, r2, r3) | Jmp _ -> []
| 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
let make_block () = let make_block () =
{ ins_list_rev = [] } { ins_list_rev = [] }
@ -78,8 +75,8 @@ let iter_blocks_df f b0 =
the whole list is pointless. but just to be safe ... *) the whole list is pointless. but just to be safe ... *)
List.iter List.iter
(function (function
| JMP b1 -> enqueue b1 | Jmp b1 -> enqueue b1
| CBR (_, b1, b2) -> enqueue b1; enqueue b2 | Btr (_, b1, b2) -> enqueue b1; enqueue b2
| _ -> ()) | _ -> ())
b.ins_list_rev; b.ins_list_rev;
loop () loop ()
@ -103,7 +100,7 @@ let make_funct n_args entry =
fsize := fsize :=
List.rev_map registers b.ins_list_rev List.rev_map registers b.ins_list_rev
|> List.flatten |> 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) !fsize)
entry; entry;
!fsize !fsize
@ -113,7 +110,16 @@ let make_funct n_args entry =
(* pretty printing *) (* 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) = let pp_vtable ~tbname ppf (vtb : vtable) =
Fmt.pf ppf "%s(%d){" (tbname vtb) vtb.n_slots; Fmt.pf ppf "%s(%d){" (tbname vtb) vtb.n_slots;
@ -127,30 +133,38 @@ let pp_vtable ~tbname ppf (vtb : vtable) =
vtb.elems; vtb.elems;
Fmt.pf ppf "}" 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 let pp_ins ~tbname ~label ppf = function
| LDI (a, b) -> Fmt.pf ppf "mov %a, %s" pp_reg a (Value.to_string b) | Mov (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_arg b
| LDR (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_reg b | Opr (o, a, b) -> Fmt.pf ppf "%s %a, %a" (string_of_opr o) pp_reg a pp_arg b
| ADD (a, b, c) -> Fmt.pf ppf "add %a, %a, %a" pp_reg a pp_reg b pp_reg c | Get (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_loc b
| SUB (a, b, c) -> Fmt.pf ppf "sub %a, %a, %a" pp_reg a pp_reg b pp_reg c | Set (a, b) -> Fmt.pf ppf "mov %a, %a" pp_loc a pp_arg b
| MUL (a, b, c) -> Fmt.pf ppf "mul %a, %a, %a" pp_reg a pp_reg b pp_reg c | Con (a, vtb) -> Fmt.pf ppf "con %a, %a" pp_reg a (pp_vtable ~tbname) vtb
| LST (a, b, c) -> Fmt.pf ppf "lst %a, %a, %a" pp_reg a pp_reg b pp_reg c | Loc (a, b, nam) -> Fmt.pf ppf "loc %a, %a.<%s>" pp_reg a pp_reg b nam
| GRT (a, b, c) -> Fmt.pf ppf "grt %a, %a, %a" pp_reg a pp_reg b pp_reg c | Jmp b -> Fmt.pf ppf "jmp %s" (label b)
| EQL (a, b, c) -> Fmt.pf ppf "eql %a, %a, %a" pp_reg a pp_reg b pp_reg c | Ret a -> Fmt.pf ppf "ret %a" pp_arg a
| NOT (a, b) -> Fmt.pf ppf "not %a, %a" pp_reg a pp_reg b | Btr (a, b1, b2) ->
| 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) ->
let l1 = label b1 in let l1 = label b1 in
let l2 = label b2 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 dump ?(recursive = true) println main_fn =
let tbqueue = ref [] in let tbqueue = ref [] in

78
lib/runtime/interp.ml
View File

@ -33,21 +33,21 @@ module Prim = struct
with with
Not_found -> runtime_error "no such element %S" name Not_found -> runtime_error "no such element %S" name
let get obj loc = let get (obj, loc) =
match obj, Value.to_elem loc with match obj, Value.to_elem loc with
| Value.Obj (_, s), Field i -> s.(i) | Value.Obj (_, s), Field i -> s.(i)
| Value.Obj (_, _), Method _ -> failwith "Interp.Prim.get: TODO: fcf" | Value.Obj (_, _), Method _ -> failwith "Interp.Prim.get: TODO: fcf"
| exception Invalid_argument _ -> runtime_error "invalid index" | exception Invalid_argument _ -> runtime_error "invalid index"
| _ -> runtime_error "get field of non-object" | _ -> runtime_error "get field of non-object"
let set obj loc v = let set (obj, loc) v =
match obj, Value.to_elem loc with match obj, Value.to_elem loc with
| Value.Obj (_, s), Field i -> s.(i) <- v | Value.Obj (_, s), Field i -> s.(i) <- v
| Value.Obj (_, _), Method _ -> runtime_error "cannot reassign method" | Value.Obj (_, _), Method _ -> runtime_error "cannot reassign method"
| exception Invalid_argument _ -> runtime_error "invalid index" | exception Invalid_argument _ -> runtime_error "invalid index"
| _ -> runtime_error "set field of non-object" | _ -> runtime_error "set field of non-object"
let mthd obj loc = let mthd (obj, loc) =
match obj, Value.to_elem loc with match obj, Value.to_elem loc with
| Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i) | Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i)
| Value.Obj (_, _), Field _ -> failwith "Interp.Prim.mthd: TODO: fcf" | Value.Obj (_, _), Field _ -> failwith "Interp.Prim.mthd: TODO: fcf"
@ -58,37 +58,51 @@ module Prim = struct
end end
type frame = { type frame = {
r : Value.t array; rg : Value.t array;
mutable pc : Code.ins list; mutable pc : Code.ins list;
mutable rv : Value.t; mutable rv : Value.t;
} }
let jmp fr b = fr.pc <- Code.instructions b let jmp fr b = fr.pc <- Code.instructions b
let rec exec ({ r; _ } as fr) = function let get fr (`R a) = fr.rg.(a)
| Code.LDI (R a, v) -> r.(a) <- v let set fr (`R a) b = fr.rg.(a) <- b
| Code.LDR (R a, R b) -> r.(a) <- r.(b) let arg fr = function
| Code.ADD (R a, R b, R c) -> r.(a) <- Prim.add r.(b) r.(c) | #Code.reg as r -> get fr r
| Code.SUB (R a, R b, R c) -> r.(a) <- Prim.sub r.(b) r.(c) | `Cst v -> v
| 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) let opr = function
| Code.GRT (R a, R b, R c) -> r.(a) <- Prim.grt r.(b) r.(c) | Code.ADD -> Prim.add
| Code.NOT (R a, R b) -> r.(a) <- Prim.not r.(b) | Code.SUB -> Prim.sub
| Code.EQL (R a, R b, R c) -> r.(a) <- Prim.eql r.(b) r.(c) | Code.MUL -> Prim.mul
| Code.GET (R a, R b, R c) -> r.(a) <- Prim.get r.(b) r.(c) | Code.DIV -> failwith "Interp: TODO(DIV)"
| Code.SET (R a, R b, R c) -> Prim.set r.(b) r.(c) r.(a) | Code.MOD -> Prim.add
| Code.LOC (R a, R b, el) -> r.(a) <- Prim.loc r.(b) el | Code.NOT -> fun _ v -> Prim.not v
| Code.CON (R a, vtbl) -> r.(a) <- Value.make_obj vtbl | Code.NEG -> failwith "Interp: TODO(NEG)"
| Code.CAL (R a, R b, R c, args) -> | Code.Cmp EQ -> Prim.eql
let obj, mthd = Prim.mthd r.(b) r.(c) in | Code.Cmp GT -> Prim.grt
let args = List.map (fun (Code.R i) -> r.(i)) args in | Code.Cmp LT -> Prim.lst
r.(a) <- call mthd obj args
| Code.JMP b -> jmp fr b let loc fr = function
| Code.CBR (R a, b1, b2) -> | a, (#Code.reg as b) -> get fr a, get fr b
jmp fr (if Value.truthy r.(a) then b1 else b2) | a, (`Ofs ofs) -> get fr a, Value.of_int ofs
| Code.RET (R a) ->
fr.rv <- r.(a); let rec exec fr = function
fr.pc <- [] | 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 = and call mthd self args =
match mthd with match mthd with
@ -109,11 +123,11 @@ and run fn self args =
runtime_error "wrong number of arguments, expected %d, got %d" runtime_error "wrong number of arguments, expected %d, got %d"
n_args (List.length args); n_args (List.length args);
let r = Array.make frame_size Value.Nil in let rg = Array.make frame_size Value.Nil in
r.(0) <- self; rg.(0) <- self;
List.iteri (fun i v -> r.(i + 1) <- v) args; 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; jmp fr entry;
step fr; step fr;
fr.rv fr.rv