big clean up of Code, Interp, removed all of Bcc
This commit is contained in:
parent
ec9dffc780
commit
c51b482607
|
|
@ -1,150 +1,9 @@
|
|||
module Ast = Spice_syntax.Ast
|
||||
module Code = Spice_runtime.Code
|
||||
module Value = Spice_runtime.Value
|
||||
module Interp = Spice_runtime.Interp
|
||||
module Env = Map.Make (String)
|
||||
|
||||
type binding = {
|
||||
self : Code.regidx;
|
||||
elem : Value.elem;
|
||||
}
|
||||
let compile modl lib =
|
||||
let _ : Ast.modl = modl in
|
||||
let _ = lib in
|
||||
|
||||
let compile modl =
|
||||
let ep = Code.make_basic_block [] in
|
||||
let bb = ref ep in
|
||||
|
||||
let emit is = Code.add_ins !bb is in
|
||||
let emit_mov lhs rhs = if rhs <> Code.Reg lhs then emit (MOV (lhs, rhs)) in
|
||||
|
||||
let rec compile_exp env sp = function
|
||||
| Ast.Literal Nil -> Code.Cst_nil
|
||||
| Ast.Literal True -> Code.Cst_true
|
||||
| Ast.Literal False -> Code.Cst_false
|
||||
| Ast.Literal (Int i) -> Code.Cst_int i
|
||||
| Ast.Path (Var name) -> (
|
||||
match Env.find name env with
|
||||
| exception Not_found -> Fmt.failwith "unbound: %S" name
|
||||
| { self; elem } ->
|
||||
let idx = Code.cst (Value.of_elem elem) in
|
||||
emit_mov sp idx;
|
||||
emit (GET (self, sp));
|
||||
Reg sp)
|
||||
| Ast.Path (Ele (obj, ele)) ->
|
||||
emit_mov (sp + 1) (compile_exp env sp obj);
|
||||
emit (SLT (sp + 1, sp, ele));
|
||||
emit (GET (sp + 1, sp));
|
||||
Reg sp
|
||||
| Ast.Call (Var name, args) -> (
|
||||
match Env.find name env with
|
||||
| exception Not_found -> Fmt.failwith "unbound: %S" name
|
||||
| { self; elem } ->
|
||||
List.iteri
|
||||
(fun i arg ->
|
||||
let sp = sp + i + 1 in
|
||||
emit_mov sp (compile_exp env sp arg))
|
||||
args;
|
||||
let idx = Code.cst (Value.of_elem elem) in
|
||||
emit_mov sp idx;
|
||||
emit (CLL (self, sp, List.length args));
|
||||
Reg sp)
|
||||
| Ast.Binop (op, lhs, rhs) ->
|
||||
let lhs = compile_exp env sp lhs in
|
||||
emit_mov sp lhs;
|
||||
let rhs = compile_exp env (sp + 1) rhs in
|
||||
(match op with
|
||||
| Ast.Add -> emit (ADD (sp, rhs))
|
||||
| Ast.Sub -> emit (SUB (sp, rhs))
|
||||
| Ast.Mul -> emit (MUL (sp, rhs))
|
||||
| Ast.Div | Ast.Mod -> failwith "Bcc.compile_exp: TODO: div/mod"
|
||||
| Ast.Eql -> emit (EQL (sp, rhs))
|
||||
| Ast.Not_eql -> emit (EQL (sp, rhs)); emit (NOT sp)
|
||||
| Ast.Lst -> emit (LST (sp, rhs))
|
||||
| Ast.Lst_eql -> emit (LST (sp, rhs)); emit (NOT sp)
|
||||
| Ast.Grt -> emit (GRT (sp, rhs))
|
||||
| Ast.Grt_eql -> emit (LST (sp, rhs)); emit (NOT sp));
|
||||
Reg sp
|
||||
| Ast.If (cnd, e1, e2) ->
|
||||
let l1 = Code.make_basic_block [] in
|
||||
let l2 = Code.make_basic_block [] in
|
||||
let jp = Code.make_basic_block [] in
|
||||
emit (CBR (compile_exp env sp cnd, l1, l2));
|
||||
bb := l1;
|
||||
emit_mov sp (compile_exp env sp e1);
|
||||
emit (JMP jp);
|
||||
bb := l2;
|
||||
emit_mov sp (compile_exp env sp e2);
|
||||
emit (JMP jp);
|
||||
bb := jp;
|
||||
Reg sp
|
||||
| Ast.Obj body -> compile_obj env sp body
|
||||
| Ast.Scope body -> compile_scope env sp body
|
||||
| _ -> failwith "Bcc.compile_exp: TODO"
|
||||
|
||||
and compile_block env sp items =
|
||||
let self = sp in
|
||||
let sp = sp + 1 in
|
||||
|
||||
(* construct new env and vtable *)
|
||||
let elems = Hashtbl.create (List.length items * 2) in
|
||||
let env, n_slots =
|
||||
List.fold_left
|
||||
(fun (env, n) -> function
|
||||
| Ast.Item_fun (_, _, _) | Ast.Item_exp _ ->
|
||||
env, n
|
||||
| Ast.Item_obj (name, _) | Ast.Item_val (name, _) ->
|
||||
let elem = Value.Field n in
|
||||
let env = Env.add name { self; elem } env in
|
||||
Hashtbl.add elems name elem;
|
||||
env, n + 1)
|
||||
(env, 0)
|
||||
items
|
||||
in
|
||||
|
||||
(* compile methods *)
|
||||
let mthds = [||] in
|
||||
|
||||
(* emit constructor, compile val fields, and get result of final expression *)
|
||||
let vtable = Value.{ n_slots; elems; mthds } in
|
||||
emit (CON (self, vtable));
|
||||
let emit_set name rhs =
|
||||
let { elem; _ } = Env.find name env in
|
||||
let idx = Code.cst (Value.of_elem elem) in
|
||||
emit_mov sp idx;
|
||||
emit_mov (sp + 1) rhs;
|
||||
emit (SET (self, sp))
|
||||
in
|
||||
let final_exp =
|
||||
List.fold_left
|
||||
(fun _ -> function
|
||||
| Ast.Item_fun (_, _, _) -> failwith "Bcc: unsupported: methods"
|
||||
| Ast.Item_exp exp ->
|
||||
Some (compile_exp env sp exp)
|
||||
| Ast.Item_obj (name, body) ->
|
||||
emit_set name (compile_obj env (sp + 1) body);
|
||||
None
|
||||
| Ast.Item_val (name, rhs) ->
|
||||
emit_set name (compile_exp env (sp + 1) rhs);
|
||||
None)
|
||||
None
|
||||
items
|
||||
in
|
||||
self, final_exp
|
||||
|
||||
and compile_obj env sp items =
|
||||
let self, _ = compile_block env sp items in
|
||||
Code.Reg self
|
||||
and compile_scope env sp items =
|
||||
let _, final_exp = compile_block env sp items in
|
||||
match final_exp with
|
||||
| None -> failwith "block must end with an expression"
|
||||
| Some ret -> ret
|
||||
in
|
||||
|
||||
let stdlib_env =
|
||||
List.to_seq Interp.stdlib
|
||||
|> Seq.mapi (fun i (name, _) -> name, { self = 0; elem = Value.Method i })
|
||||
|> Env.of_seq
|
||||
in
|
||||
emit_mov 0 (compile_obj stdlib_env 1 modl.Ast.items);
|
||||
emit RET;
|
||||
Code.make_program ep
|
||||
let ep = Code.make_block () in
|
||||
{ Code.entry = ep }
|
||||
|
|
|
|||
|
|
@ -1,117 +1,104 @@
|
|||
type regidx = int
|
||||
module Ast = Spice_syntax.Ast
|
||||
|
||||
type operand =
|
||||
| Cst_nil
|
||||
| Cst_true
|
||||
| Cst_false
|
||||
| Cst_int of int64
|
||||
| Reg of regidx
|
||||
type imm = Value.t
|
||||
type vtable = Value.vtable
|
||||
|
||||
let cst = function
|
||||
| Value.Nil -> Cst_nil
|
||||
| Value.True -> Cst_true
|
||||
| Value.False -> Cst_false
|
||||
| Value.Int i -> Cst_int i
|
||||
| _ -> invalid_arg "value cannot be converted to constant operand"
|
||||
type reg = R of int [@@unboxed]
|
||||
|
||||
type basic_block = {
|
||||
mutable ins_builder : ins list;
|
||||
mutable ins_list : ins list;
|
||||
(* bc_pc : int *)
|
||||
(* bc_len : int *)
|
||||
}
|
||||
|
||||
and ins =
|
||||
| MOV of regidx * operand
|
||||
| ADD of regidx * operand
|
||||
| SUB of regidx * operand
|
||||
| MUL of regidx * operand
|
||||
| EQL of regidx * operand
|
||||
| LST of regidx * operand
|
||||
| GRT of regidx * operand
|
||||
| NOT of regidx
|
||||
| CON of regidx * Value.vtable
|
||||
| SLT of regidx * regidx * string
|
||||
| GET of regidx * regidx
|
||||
| SET of regidx * regidx
|
||||
| CLL of regidx * regidx * int
|
||||
| JMP of basic_block
|
||||
| CBR of operand * basic_block * basic_block
|
||||
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
|
||||
(* control flow *)
|
||||
| RET
|
||||
| JMP of block
|
||||
| CBR of reg * block * block
|
||||
|
||||
let make_basic_block ins_list = {
|
||||
ins_builder = List.rev ins_list;
|
||||
ins_list
|
||||
}
|
||||
and block =
|
||||
{ mutable ins_list_rev : ins list }
|
||||
|
||||
let instructions bb =
|
||||
(* memoize computing "rev ins_builder" by storing result in ins_list *)
|
||||
if bb.ins_list = [] then
|
||||
bb.ins_list <- List.rev bb.ins_builder;
|
||||
bb.ins_list
|
||||
let make_block () =
|
||||
{ ins_list_rev = [] }
|
||||
|
||||
let add_ins bb is =
|
||||
(* "append" instruction by prepending to ins_builder list *)
|
||||
bb.ins_builder <- is :: bb.ins_builder;
|
||||
(* invalidate the cache *)
|
||||
bb.ins_list <- []
|
||||
let extend t ins =
|
||||
t.ins_list_rev <- ins :: t.ins_list_rev
|
||||
|
||||
type program = { entrypoint : basic_block }
|
||||
type Value.mthd += Method of program
|
||||
let instructions t =
|
||||
List.rev t.ins_list_rev
|
||||
|
||||
let make_program entrypoint =
|
||||
{ entrypoint }
|
||||
|
||||
let frame_size prog =
|
||||
let visited = ref [] in
|
||||
let work_list = ref [ prog.entrypoint ] in
|
||||
let enqueue bb = if not (List.memq bb !visited) then work_list := bb :: !work_list in
|
||||
let reg acc i = max acc (i + 1) in
|
||||
let op acc = function
|
||||
| Reg i -> reg acc i
|
||||
| _ -> acc
|
||||
type prog =
|
||||
{ entry : block }
|
||||
|
||||
(* like [Seq.flat_map] but may change the ordering *)
|
||||
let flat_map_u f lst =
|
||||
let rec go acc = function
|
||||
| [] -> []
|
||||
| x :: xs -> go (List.rev_append (f x) acc) xs
|
||||
in
|
||||
let ins acc = function
|
||||
| MOV (r, v)
|
||||
| ADD (r, v)
|
||||
| SUB (r, v)
|
||||
| MUL (r, v)
|
||||
| EQL (r, v)
|
||||
| LST (r, v)
|
||||
| GRT (r, v) -> op (reg acc r) v
|
||||
| CON (r, _) | NOT r -> reg acc r
|
||||
| GET (o, s) | SLT (o, s, _) -> reg (reg acc o) s
|
||||
| SET (o, s) -> reg (reg acc o) (s + 1)
|
||||
| CBR (v, b1, b2) ->
|
||||
enqueue b1;
|
||||
enqueue b2;
|
||||
op acc v
|
||||
| CLL (o, m, k) -> reg (reg acc o) (m + k + 1)
|
||||
go [] lst
|
||||
|
||||
let frame_size t =
|
||||
let queue = ref [ t.entry ] in
|
||||
let visited = ref !queue in
|
||||
let enqueue b =
|
||||
if not (List.memq b !visited) then (
|
||||
queue := b :: !queue;
|
||||
visited := b :: !visited)
|
||||
in
|
||||
let meas (R i) fs = max fs (i + 1) in
|
||||
let meas_ins fs = function
|
||||
| RET -> fs
|
||||
| LDI (r, _)
|
||||
| CON (r, _)
|
||||
-> meas r fs
|
||||
| LDR (r1, r2)
|
||||
| NOT (r1, r2)
|
||||
| LOC (r1, r2, _)
|
||||
-> meas r1 (meas r2 fs)
|
||||
| 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)
|
||||
-> meas r1 (meas r2 (meas r3 fs))
|
||||
| JMP b ->
|
||||
enqueue b;
|
||||
acc
|
||||
| RET -> acc
|
||||
fs
|
||||
| CBR (r, b1, b2) ->
|
||||
enqueue b1;
|
||||
enqueue b2;
|
||||
meas r fs
|
||||
in
|
||||
let rec loop acc =
|
||||
match !work_list with
|
||||
| [] -> acc
|
||||
| bb :: rest ->
|
||||
visited := bb :: !visited;
|
||||
work_list := rest;
|
||||
List.fold_left ins acc (instructions bb) |> loop
|
||||
let rec loop fs =
|
||||
match !queue with
|
||||
| [] -> fs
|
||||
| bl :: rest ->
|
||||
queue := rest;
|
||||
loop (List.fold_left meas_ins fs bl.ins_list_rev)
|
||||
in
|
||||
loop 1
|
||||
|
||||
(* pretty printing *)
|
||||
|
||||
let pp_reg ppf r = Fmt.pf ppf "$%d" r
|
||||
|
||||
let pp_operand ppf = function
|
||||
| Cst_nil -> Fmt.pf ppf "nil"
|
||||
| Cst_true -> Fmt.pf ppf "true"
|
||||
| Cst_false -> Fmt.pf ppf "false"
|
||||
| Cst_int n -> Fmt.pf ppf "#%s" (Int64.to_string n)
|
||||
| Reg r -> pp_reg ppf r
|
||||
let pp_reg ppf (R i) = Fmt.pf ppf "R%d" i
|
||||
|
||||
let pp_vtable ppf vt =
|
||||
Fmt.pf ppf "(%d){" vt.Value.n_slots;
|
||||
|
|
@ -126,36 +113,29 @@ let pp_vtable ppf vt =
|
|||
Fmt.pf ppf "}"
|
||||
|
||||
let pp_ins ~label ppf = function
|
||||
| MOV (l, r) -> Fmt.pf ppf "mov %a, %a" pp_reg l pp_operand r
|
||||
| ADD (l, r) -> Fmt.pf ppf "add %a, %a" pp_reg l pp_operand r
|
||||
| SUB (l, r) -> Fmt.pf ppf "sub %a, %a" pp_reg l pp_operand r
|
||||
| MUL (l, r) -> Fmt.pf ppf "mul %a, %a" pp_reg l pp_operand r
|
||||
| EQL (l, r) -> Fmt.pf ppf "eql %a, %a" pp_reg l pp_operand r
|
||||
| LST (l, r) -> Fmt.pf ppf "lst %a, %a" pp_reg l pp_operand r
|
||||
| GRT (l, r) -> Fmt.pf ppf "grt %a, %a" pp_reg l pp_operand r
|
||||
| NOT l -> Fmt.pf ppf "not %a" pp_reg l
|
||||
| CON (l, vt) -> Fmt.pf ppf "con %a, %a" pp_reg l pp_vtable vt
|
||||
| SLT (o, s, n) -> Fmt.pf ppf "mov %a, @%a.%s" pp_reg s pp_reg o n
|
||||
| GET (o, s) -> Fmt.pf ppf "mov %a, %a[%a]" pp_reg s pp_reg o pp_reg s
|
||||
| SET (o, s) -> Fmt.pf ppf "mov %a[%a], %a" pp_reg o pp_reg s pp_reg (s + 1)
|
||||
| CLL (o, m, k) ->
|
||||
Fmt.pf ppf "cll %a, %a[%a](" pp_reg m pp_reg o pp_reg m;
|
||||
for i = 1 to k do
|
||||
if i > 1 then Fmt.pf ppf ",";
|
||||
Fmt.pf ppf "%a" pp_reg (m + i)
|
||||
done;
|
||||
Fmt.pf ppf ")"
|
||||
| CBR (v, b1, b2) ->
|
||||
| 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 "mov %a, &%a.%s" pp_reg a pp_reg b el
|
||||
| CON (a, vt) -> Fmt.pf ppf "con %a, %a" pp_reg a pp_vtable vt
|
||||
| RET -> Fmt.pf ppf "ret"
|
||||
| JMP b -> Fmt.pf ppf "jmp %s" (label b)
|
||||
| CBR (a, b1, b2) ->
|
||||
let l1 = label b1 in
|
||||
let l2 = label b2 in
|
||||
Fmt.pf ppf "cbr %a, %s, %s" pp_operand v l1 l2
|
||||
| RET -> Fmt.pf ppf "ret"
|
||||
| JMP l -> Fmt.pf ppf "jmp %s" (label l)
|
||||
Fmt.pf ppf "cbr %a, %s, %s" pp_reg a l1 l2
|
||||
|
||||
let pp_program ppf pr =
|
||||
let ep = pr.entrypoint in
|
||||
let basic_blocks = ref [ ep, "START" ] in
|
||||
let work_list = ref [ ep ] in
|
||||
let pp_program ppf prog =
|
||||
let basic_blocks = ref [ prog.entry, "START" ] in
|
||||
let work_list = ref [ prog.entry ] in
|
||||
let label bb =
|
||||
try List.assq bb !basic_blocks
|
||||
with Not_found ->
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
(library
|
||||
(name spice_runtime)
|
||||
(libraries fmt))
|
||||
(libraries spice_syntax fmt))
|
||||
|
|
|
|||
|
|
@ -3,170 +3,99 @@ exception Runtime_error of string
|
|||
let runtime_error f =
|
||||
Fmt.kstr (fun s -> raise (Runtime_error s)) f
|
||||
|
||||
module Op = struct
|
||||
let add v1 v2 =
|
||||
module Prim = struct
|
||||
let intop name ( ** ) v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.Int (Int64.add x y)
|
||||
| _, _ -> runtime_error "cannot add non integer values"
|
||||
| Value.Int x, Value.Int y -> Value.Int (x ** y)
|
||||
| _, _ -> runtime_error "cannot %s non integer values" name
|
||||
|
||||
let sub v1 v2 =
|
||||
let cmpop ( </> ) v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.Int (Int64.sub x y)
|
||||
| _, _ -> runtime_error "cannot sub non integer values"
|
||||
|
||||
let mul v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.Int (Int64.mul x y)
|
||||
| _, _ -> runtime_error "cannot mul non integer values"
|
||||
|
||||
let eql v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.bool (Int64.equal x y)
|
||||
| _, _ -> Value.bool (v1 == v2)
|
||||
|
||||
let lst v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.bool (Int64.compare x y < 0)
|
||||
| Value.Int x, Value.Int y -> Value.of_bool (Int64.compare x y </> 0)
|
||||
| _, _ -> runtime_error "cannot compare non integer values"
|
||||
|
||||
let grt v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.bool (Int64.compare x y > 0)
|
||||
| _, _ -> runtime_error "cannot compare non integer values"
|
||||
let add = intop "add" Int64.add
|
||||
let sub = intop "sub" Int64.sub
|
||||
let mul = intop "mul" Int64.mul
|
||||
let lst = cmpop ( < )
|
||||
let grt = cmpop ( > )
|
||||
let eql v1 v2 = Value.of_bool (Value.equal v1 v2)
|
||||
let not v = Value.of_bool (not (Value.truthy v))
|
||||
|
||||
let is_truthy = function
|
||||
| Value.False | Value.Nil -> false
|
||||
| _ -> true
|
||||
let loc obj name =
|
||||
try
|
||||
match obj with
|
||||
| Value.Obj (vtable, _) ->
|
||||
Value.of_elem (Hashtbl.find vtable.elems name)
|
||||
| _ ->
|
||||
(* TODO: vtable of primitive types *)
|
||||
raise Not_found
|
||||
with
|
||||
Not_found -> runtime_error "no such element %S" name
|
||||
|
||||
let not v = Value.bool (not (is_truthy v))
|
||||
|
||||
let slt obj name =
|
||||
match obj with
|
||||
| Value.Obj (vtable, _) ->
|
||||
begin
|
||||
try Value.of_elem (Hashtbl.find vtable.elems name)
|
||||
with Not_found -> runtime_error "no such element %S" name
|
||||
end
|
||||
| _ -> runtime_error "get element of non-object"
|
||||
|
||||
let get obj el =
|
||||
match obj, Value.to_elem el with
|
||||
| Value.Obj (_, slots), Field i -> slots.(i)
|
||||
| Value.Obj (_, _), Method _ -> failwith "Interp.Op.get: TODO: method reification"
|
||||
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 el v =
|
||||
match obj, Value.to_elem el with
|
||||
| Value.Obj (_, slots), Field i -> slots.(i) <- 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 el =
|
||||
match obj, Value.to_elem el with
|
||||
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.Op.get: TODO: fcf calls"
|
||||
| Value.Obj (_, _), Field _ -> failwith "Interp.Prim.mthd: TODO: fcf"
|
||||
| exception Invalid_argument _ -> runtime_error "invalid index"
|
||||
| _ ->
|
||||
(* TODO: create vtable from primitive types *)
|
||||
runtime_error "call field of non-object"
|
||||
(* TODO: vtable of primitive types *)
|
||||
runtime_error "call method of non-object"
|
||||
end
|
||||
|
||||
type frame = {
|
||||
regs : Value.t array;
|
||||
r : Value.t array;
|
||||
mutable pc : Code.ins list;
|
||||
}
|
||||
|
||||
let eval fr = function
|
||||
| Code.Cst_nil -> Value.Nil
|
||||
| Code.Cst_true -> Value.True
|
||||
| Code.Cst_false -> Value.False
|
||||
| Code.Cst_int n -> Value.Int n
|
||||
| Code.Reg i -> fr.regs.(i)
|
||||
let jmp fr b = fr.pc <- Code.instructions b
|
||||
|
||||
let rec exec fr = function
|
||||
| Code.MOV (l, r) -> fr.regs.(l) <- eval fr r
|
||||
| Code.ADD (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
|
||||
| Code.SUB (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
|
||||
| Code.MUL (l, r) -> fr.regs.(l) <- Op.mul fr.regs.(l) (eval fr r)
|
||||
| Code.EQL (l, r) -> fr.regs.(l) <- Op.eql fr.regs.(l) (eval fr r)
|
||||
| Code.LST (l, r) -> fr.regs.(l) <- Op.lst fr.regs.(l) (eval fr r)
|
||||
| Code.GRT (l, r) -> fr.regs.(l) <- Op.grt fr.regs.(l) (eval fr r)
|
||||
| Code.NOT l -> fr.regs.(l) <- Op.not fr.regs.(l)
|
||||
| Code.CON (l, vt) -> fr.regs.(l) <- Value.make_obj vt
|
||||
| Code.SLT (o, e, nm) -> fr.regs.(e) <- Op.slt fr.regs.(o) nm
|
||||
| Code.GET (o, e) -> fr.regs.(e) <- Op.get fr.regs.(o) fr.regs.(e)
|
||||
| Code.SET (o, e) -> Op.set fr.regs.(o) fr.regs.(e) fr.regs.(e + 1)
|
||||
| Code.RET -> fr.pc <- []
|
||||
| Code.CLL (o, m, k) ->
|
||||
let self, mthd = Op.mthd fr.regs.(o) fr.regs.(m) in
|
||||
let args = List.init k (fun i -> fr.regs.(m + i + 1)) in
|
||||
fr.regs.(m) <- call mthd self args
|
||||
| Code.JMP l -> fr.pc <- Code.instructions l
|
||||
| Code.CBR (v, l1, l2) ->
|
||||
fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2)
|
||||
let 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.JMP b -> jmp fr b
|
||||
| Code.CBR (R a, b1, b2) ->
|
||||
jmp fr (if Value.truthy r.(a) then b1 else b2)
|
||||
| Code.RET ->
|
||||
fr.pc <- []
|
||||
|
||||
and call mthd self args =
|
||||
match mthd with
|
||||
| Code.Method pr ->
|
||||
if args <> [] then failwith "Interp.call: TODO: method arguments";
|
||||
run pr self
|
||||
| _ -> Value.call mthd self args
|
||||
let rec step fr =
|
||||
match fr.pc with
|
||||
| [] -> ()
|
||||
| i :: rest ->
|
||||
fr.pc <- rest;
|
||||
exec fr i;
|
||||
step fr
|
||||
|
||||
and run prog self =
|
||||
let frame_size = 1 in
|
||||
let frame_size = max frame_size (Code.frame_size prog) in
|
||||
let fr = {
|
||||
regs = Array.make frame_size Value.Nil;
|
||||
pc = Code.instructions prog.entrypoint;
|
||||
} in
|
||||
let rec run_loop () =
|
||||
match fr.pc with
|
||||
| [] -> ()
|
||||
| ins :: rest ->
|
||||
fr.pc <- rest;
|
||||
exec fr ins;
|
||||
run_loop ()
|
||||
in
|
||||
fr.regs.(0) <- self;
|
||||
run_loop ();
|
||||
fr.regs.(0)
|
||||
|
||||
let stdlib =
|
||||
let println vs =
|
||||
let pp ppf vs =
|
||||
List.iteri
|
||||
(fun i v ->
|
||||
if i > 0 then Fmt.pf ppf " ";
|
||||
Value.pp ppf v)
|
||||
vs
|
||||
in
|
||||
Fmt.pr "%a\n" pp vs;
|
||||
Value.Nil
|
||||
in
|
||||
let min = function
|
||||
| [] -> runtime_error "zero arguments to min()"
|
||||
| [ v ] -> v
|
||||
| v :: vs ->
|
||||
List.fold_left
|
||||
(fun v1 v2 ->
|
||||
match Op.lst v1 v2 with
|
||||
| Value.True -> v1
|
||||
| _ -> v2)
|
||||
v
|
||||
vs
|
||||
in
|
||||
let max = function
|
||||
| [] -> runtime_error "zero arguments to max()"
|
||||
| [ v ] -> v
|
||||
| v :: vs ->
|
||||
List.fold_left
|
||||
(fun v1 v2 ->
|
||||
match Op.grt v1 v2 with
|
||||
| Value.True -> v1
|
||||
| _ -> v2)
|
||||
v
|
||||
vs
|
||||
in
|
||||
[ "println", println; "min", min; "max", max ]
|
||||
let run prog self =
|
||||
let r = Array.make (Code.frame_size prog) Value.Nil in
|
||||
let fr = { r; pc = [] } in
|
||||
r.(0) <- self;
|
||||
jmp fr prog.entry;
|
||||
step fr;
|
||||
r.(0)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,39 @@
|
|||
open Interp
|
||||
|
||||
let println vs =
|
||||
let pp ppf vs =
|
||||
List.iteri
|
||||
(fun i v ->
|
||||
if i > 0 then Fmt.pf ppf " ";
|
||||
Value.pp ppf v)
|
||||
vs
|
||||
in
|
||||
Fmt.pr "%a\n" pp vs;
|
||||
Value.Nil
|
||||
|
||||
let min = function
|
||||
| [] -> runtime_error "zero arguments to min()"
|
||||
| [ v ] -> v
|
||||
| v :: vs ->
|
||||
List.fold_left
|
||||
(fun v1 v2 ->
|
||||
if Value.truthy (Prim.lst v1 v2) then v1 else v2)
|
||||
v
|
||||
vs
|
||||
|
||||
let max = function
|
||||
| [] -> runtime_error "zero arguments to max()"
|
||||
| [ v ] -> v
|
||||
| v :: vs ->
|
||||
List.fold_left
|
||||
(fun v1 v2 ->
|
||||
if Value.truthy (Prim.grt v1 v2) then v1 else v2)
|
||||
v
|
||||
vs
|
||||
|
||||
let lib = [
|
||||
"println", println;
|
||||
"min", min;
|
||||
"max", max;
|
||||
]
|
||||
|
||||
|
|
@ -13,6 +13,7 @@ and elem =
|
|||
|
||||
and mthd = ..
|
||||
|
||||
|
||||
type t =
|
||||
| Nil
|
||||
| True
|
||||
|
|
@ -20,19 +21,34 @@ type t =
|
|||
| Int of int64
|
||||
| Obj of vtable * t array
|
||||
|
||||
let make_obj vtable = Obj (vtable, Array.make vtable.n_slots Nil)
|
||||
let make_obj vtable =
|
||||
Obj (vtable, Array.make vtable.n_slots Nil)
|
||||
|
||||
let bool = function
|
||||
let of_int n =
|
||||
Int (Int64.of_int n)
|
||||
|
||||
let of_bool = function
|
||||
| true -> True
|
||||
| false -> False
|
||||
|
||||
let truthy = function
|
||||
| False | Nil -> false
|
||||
| _ -> true
|
||||
|
||||
let equal v1 v2 =
|
||||
match v1, v2 with
|
||||
| Int x, Int y -> Int64.equal x y
|
||||
| _, _ -> v1 == v2
|
||||
|
||||
(* TODO (?): move some Obj helpers from Interp.Prim to here *)
|
||||
|
||||
let of_elem e =
|
||||
let idx =
|
||||
match e with
|
||||
| Field i -> i
|
||||
| Method i -> -succ i
|
||||
in
|
||||
Int (Int64.of_int idx)
|
||||
of_int idx
|
||||
|
||||
let to_elem = function
|
||||
| Int idx ->
|
||||
|
|
@ -44,6 +60,21 @@ let to_elem = function
|
|||
| _ ->
|
||||
invalid_arg "to_elem: non integer value"
|
||||
|
||||
|
||||
type mthd += Native_function of (t list -> t)
|
||||
|
||||
let call mthd _self args =
|
||||
match mthd with
|
||||
| Native_function f -> f args
|
||||
| _ -> raise Not_found
|
||||
|
||||
let native_lib fns =
|
||||
let elems = Hashtbl.create (List.length fns * 4) in
|
||||
List.iteri (fun i (name, _) -> Hashtbl.add elems name (Method i)) fns;
|
||||
let mthds = List.map (fun (_, f) -> Native_function f) fns |> Array.of_list in
|
||||
make_obj { n_slots = 0; elems; mthds }
|
||||
|
||||
|
||||
let rec pp ppf = function
|
||||
| Obj (vtable, slots) -> pp_obj ppf vtable slots
|
||||
| Int n -> Fmt.string ppf (Int64.to_string n)
|
||||
|
|
@ -66,17 +97,3 @@ and pp_obj ppf vtable slots =
|
|||
sep := ",")
|
||||
vtable.elems;
|
||||
Fmt.pf ppf "}"
|
||||
|
||||
type mthd += Native_function of (t list -> t)
|
||||
|
||||
let call mthd _self args =
|
||||
match mthd with
|
||||
| Native_function f -> f args
|
||||
| _ -> raise Not_found
|
||||
|
||||
let native_lib fns =
|
||||
let elems = Hashtbl.create (List.length fns * 4) in
|
||||
List.iteri (fun i (name, _) -> Hashtbl.add elems name (Method i)) fns;
|
||||
let mthds = List.map (fun (_, f) -> Native_function f) fns |> Array.of_list in
|
||||
let vtable = { n_slots = 0; elems; mthds } in
|
||||
Obj (vtable, [||])
|
||||
|
|
|
|||
22
lib/spice.ml
22
lib/spice.ml
|
|
@ -2,26 +2,28 @@ module Ast = Spice_syntax.Ast
|
|||
module Code = Spice_runtime.Code
|
||||
module Value = Spice_runtime.Value
|
||||
|
||||
open Spice_syntax
|
||||
open Spice_runtime
|
||||
open Spice_compile
|
||||
|
||||
exception Error of string
|
||||
|
||||
let failf f =
|
||||
Fmt.kstr (fun s -> raise (Error s)) f
|
||||
|
||||
let parse input =
|
||||
let open Spice_syntax in
|
||||
let lexbuf = Lexing.from_string input ~with_positions:true in
|
||||
try
|
||||
Parser.modl Lexer.read lexbuf
|
||||
try Parser.modl Lexer.read lexbuf
|
||||
with
|
||||
| Parser.Error -> failf "syntax error"
|
||||
| Lexer.Error msg -> failf "syntax error: %s" msg
|
||||
|
||||
let compile ast = Spice_compile.Bcc.compile ast
|
||||
let compile ast =
|
||||
try Bcc.compile ast Std.lib
|
||||
with Bcc.Error msg ->
|
||||
failf "compile error: %s" msg
|
||||
|
||||
let run prog =
|
||||
let open Spice_runtime in
|
||||
try
|
||||
let stdlib = Value.native_lib Interp.stdlib in
|
||||
Interp.run prog stdlib
|
||||
with
|
||||
| Interp.Runtime_error msg -> failf "runtime error: %s" msg
|
||||
try Interp.run prog (Value.native_lib Std.lib)
|
||||
with Interp.Runtime_error msg ->
|
||||
failf "runtime error: %s" msg
|
||||
|
|
|
|||
Loading…
Reference in New Issue