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 Ast = Spice_syntax.Ast
|
||||||
module Code = Spice_runtime.Code
|
module Code = Spice_runtime.Code
|
||||||
module Value = Spice_runtime.Value
|
|
||||||
module Interp = Spice_runtime.Interp
|
|
||||||
module Env = Map.Make (String)
|
|
||||||
|
|
||||||
type binding = {
|
let compile modl lib =
|
||||||
self : Code.regidx;
|
let _ : Ast.modl = modl in
|
||||||
elem : Value.elem;
|
let _ = lib in
|
||||||
}
|
|
||||||
|
|
||||||
let compile modl =
|
let ep = Code.make_block () in
|
||||||
let ep = Code.make_basic_block [] in
|
{ Code.entry = ep }
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -1,117 +1,104 @@
|
||||||
type regidx = int
|
module Ast = Spice_syntax.Ast
|
||||||
|
|
||||||
type operand =
|
type imm = Value.t
|
||||||
| Cst_nil
|
type vtable = Value.vtable
|
||||||
| Cst_true
|
|
||||||
| Cst_false
|
|
||||||
| Cst_int of int64
|
|
||||||
| Reg of regidx
|
|
||||||
|
|
||||||
let cst = function
|
type reg = R of int [@@unboxed]
|
||||||
| 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 basic_block = {
|
type ins =
|
||||||
mutable ins_builder : ins list;
|
(* registers *)
|
||||||
mutable ins_list : ins list;
|
| LDI of reg * imm
|
||||||
(* bc_pc : int *)
|
| LDR of reg * reg
|
||||||
(* bc_len : int *)
|
(* arithmetic *)
|
||||||
}
|
| ADD of reg * reg * reg
|
||||||
|
| SUB of reg * reg * reg
|
||||||
and ins =
|
| MUL of reg * reg * reg
|
||||||
| MOV of regidx * operand
|
(* comparison *)
|
||||||
| ADD of regidx * operand
|
| LST of reg * reg * reg
|
||||||
| SUB of regidx * operand
|
| GRT of reg * reg * reg
|
||||||
| MUL of regidx * operand
|
| EQL of reg * reg * reg
|
||||||
| EQL of regidx * operand
|
| NOT of reg * reg
|
||||||
| LST of regidx * operand
|
(* objects *)
|
||||||
| GRT of regidx * operand
|
| GET of reg * reg * reg
|
||||||
| NOT of regidx
|
| SET of reg * reg * reg
|
||||||
| CON of regidx * Value.vtable
|
| LOC of reg * reg * string
|
||||||
| SLT of regidx * regidx * string
|
| CON of reg * vtable
|
||||||
| GET of regidx * regidx
|
(* control flow *)
|
||||||
| SET of regidx * regidx
|
|
||||||
| CLL of regidx * regidx * int
|
|
||||||
| JMP of basic_block
|
|
||||||
| CBR of operand * basic_block * basic_block
|
|
||||||
| RET
|
| RET
|
||||||
|
| JMP of block
|
||||||
|
| CBR of reg * block * block
|
||||||
|
|
||||||
let make_basic_block ins_list = {
|
and block =
|
||||||
ins_builder = List.rev ins_list;
|
{ mutable ins_list_rev : ins list }
|
||||||
ins_list
|
|
||||||
}
|
|
||||||
|
|
||||||
let instructions bb =
|
let make_block () =
|
||||||
(* memoize computing "rev ins_builder" by storing result in ins_list *)
|
{ ins_list_rev = [] }
|
||||||
if bb.ins_list = [] then
|
|
||||||
bb.ins_list <- List.rev bb.ins_builder;
|
|
||||||
bb.ins_list
|
|
||||||
|
|
||||||
let add_ins bb is =
|
let extend t ins =
|
||||||
(* "append" instruction by prepending to ins_builder list *)
|
t.ins_list_rev <- ins :: t.ins_list_rev
|
||||||
bb.ins_builder <- is :: bb.ins_builder;
|
|
||||||
(* invalidate the cache *)
|
|
||||||
bb.ins_list <- []
|
|
||||||
|
|
||||||
type program = { entrypoint : basic_block }
|
let instructions t =
|
||||||
type Value.mthd += Method of program
|
List.rev t.ins_list_rev
|
||||||
|
|
||||||
let make_program entrypoint =
|
|
||||||
{ entrypoint }
|
|
||||||
|
|
||||||
let frame_size prog =
|
type prog =
|
||||||
let visited = ref [] in
|
{ entry : block }
|
||||||
let work_list = ref [ prog.entrypoint ] in
|
|
||||||
let enqueue bb = if not (List.memq bb !visited) then work_list := bb :: !work_list in
|
(* like [Seq.flat_map] but may change the ordering *)
|
||||||
let reg acc i = max acc (i + 1) in
|
let flat_map_u f lst =
|
||||||
let op acc = function
|
let rec go acc = function
|
||||||
| Reg i -> reg acc i
|
| [] -> []
|
||||||
| _ -> acc
|
| x :: xs -> go (List.rev_append (f x) acc) xs
|
||||||
in
|
in
|
||||||
let ins acc = function
|
go [] lst
|
||||||
| MOV (r, v)
|
|
||||||
| ADD (r, v)
|
let frame_size t =
|
||||||
| SUB (r, v)
|
let queue = ref [ t.entry ] in
|
||||||
| MUL (r, v)
|
let visited = ref !queue in
|
||||||
| EQL (r, v)
|
let enqueue b =
|
||||||
| LST (r, v)
|
if not (List.memq b !visited) then (
|
||||||
| GRT (r, v) -> op (reg acc r) v
|
queue := b :: !queue;
|
||||||
| CON (r, _) | NOT r -> reg acc r
|
visited := b :: !visited)
|
||||||
| GET (o, s) | SLT (o, s, _) -> reg (reg acc o) s
|
in
|
||||||
| SET (o, s) -> reg (reg acc o) (s + 1)
|
let meas (R i) fs = max fs (i + 1) in
|
||||||
| CBR (v, b1, b2) ->
|
let meas_ins fs = function
|
||||||
enqueue b1;
|
| RET -> fs
|
||||||
enqueue b2;
|
| LDI (r, _)
|
||||||
op acc v
|
| CON (r, _)
|
||||||
| CLL (o, m, k) -> reg (reg acc o) (m + k + 1)
|
-> 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 ->
|
| JMP b ->
|
||||||
enqueue b;
|
enqueue b;
|
||||||
acc
|
fs
|
||||||
| RET -> acc
|
| CBR (r, b1, b2) ->
|
||||||
|
enqueue b1;
|
||||||
|
enqueue b2;
|
||||||
|
meas r fs
|
||||||
in
|
in
|
||||||
let rec loop acc =
|
let rec loop fs =
|
||||||
match !work_list with
|
match !queue with
|
||||||
| [] -> acc
|
| [] -> fs
|
||||||
| bb :: rest ->
|
| bl :: rest ->
|
||||||
visited := bb :: !visited;
|
queue := rest;
|
||||||
work_list := rest;
|
loop (List.fold_left meas_ins fs bl.ins_list_rev)
|
||||||
List.fold_left ins acc (instructions bb) |> loop
|
|
||||||
in
|
in
|
||||||
loop 1
|
loop 1
|
||||||
|
|
||||||
(* pretty printing *)
|
(* pretty printing *)
|
||||||
|
|
||||||
let pp_reg ppf r = Fmt.pf ppf "$%d" r
|
let pp_reg ppf (R i) = Fmt.pf ppf "R%d" i
|
||||||
|
|
||||||
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_vtable ppf vt =
|
let pp_vtable ppf vt =
|
||||||
Fmt.pf ppf "(%d){" vt.Value.n_slots;
|
Fmt.pf ppf "(%d){" vt.Value.n_slots;
|
||||||
|
|
@ -126,36 +113,29 @@ let pp_vtable ppf vt =
|
||||||
Fmt.pf ppf "}"
|
Fmt.pf ppf "}"
|
||||||
|
|
||||||
let pp_ins ~label ppf = function
|
let pp_ins ~label ppf = function
|
||||||
| MOV (l, r) -> Fmt.pf ppf "mov %a, %a" pp_reg l pp_operand r
|
| LDI (a, b) -> Fmt.pf ppf "mov %a, %s" pp_reg a (Value.to_string b)
|
||||||
| ADD (l, r) -> Fmt.pf ppf "add %a, %a" pp_reg l pp_operand r
|
| LDR (a, b) -> Fmt.pf ppf "mov %a, %a" pp_reg a pp_reg b
|
||||||
| SUB (l, r) -> Fmt.pf ppf "sub %a, %a" pp_reg l pp_operand r
|
| ADD (a, b, c) -> Fmt.pf ppf "add %a, %a, %a" pp_reg a pp_reg b pp_reg c
|
||||||
| MUL (l, r) -> Fmt.pf ppf "mul %a, %a" pp_reg l pp_operand r
|
| SUB (a, b, c) -> Fmt.pf ppf "sub %a, %a, %a" pp_reg a pp_reg b pp_reg c
|
||||||
| EQL (l, r) -> Fmt.pf ppf "eql %a, %a" pp_reg l pp_operand r
|
| MUL (a, b, c) -> Fmt.pf ppf "mul %a, %a, %a" pp_reg a pp_reg b pp_reg c
|
||||||
| LST (l, r) -> Fmt.pf ppf "lst %a, %a" pp_reg l pp_operand r
|
| LST (a, b, c) -> Fmt.pf ppf "lst %a, %a, %a" pp_reg a pp_reg b pp_reg c
|
||||||
| GRT (l, r) -> Fmt.pf ppf "grt %a, %a" pp_reg l pp_operand r
|
| GRT (a, b, c) -> Fmt.pf ppf "grt %a, %a, %a" pp_reg a pp_reg b pp_reg c
|
||||||
| NOT l -> Fmt.pf ppf "not %a" pp_reg l
|
| EQL (a, b, c) -> Fmt.pf ppf "eql %a, %a, %a" pp_reg a pp_reg b pp_reg c
|
||||||
| CON (l, vt) -> Fmt.pf ppf "con %a, %a" pp_reg l pp_vtable vt
|
| NOT (a, b) -> Fmt.pf ppf "not %a, %a" pp_reg a pp_reg b
|
||||||
| SLT (o, s, n) -> Fmt.pf ppf "mov %a, @%a.%s" pp_reg s pp_reg o n
|
| GET (a, b, c) -> Fmt.pf ppf "mov %a, %a[%a]" pp_reg a pp_reg b pp_reg c
|
||||||
| GET (o, s) -> Fmt.pf ppf "mov %a, %a[%a]" pp_reg s pp_reg o pp_reg s
|
| SET (a, b, c) -> Fmt.pf ppf "mov %a[%a], %a" pp_reg b pp_reg c pp_reg a
|
||||||
| SET (o, s) -> Fmt.pf ppf "mov %a[%a], %a" pp_reg o pp_reg s pp_reg (s + 1)
|
| LOC (a, b, el) -> Fmt.pf ppf "mov %a, &%a.%s" pp_reg a pp_reg b el
|
||||||
| CLL (o, m, k) ->
|
| CON (a, vt) -> Fmt.pf ppf "con %a, %a" pp_reg a pp_vtable vt
|
||||||
Fmt.pf ppf "cll %a, %a[%a](" pp_reg m pp_reg o pp_reg m;
|
| RET -> Fmt.pf ppf "ret"
|
||||||
for i = 1 to k do
|
| JMP b -> Fmt.pf ppf "jmp %s" (label b)
|
||||||
if i > 1 then Fmt.pf ppf ",";
|
| CBR (a, b1, b2) ->
|
||||||
Fmt.pf ppf "%a" pp_reg (m + i)
|
|
||||||
done;
|
|
||||||
Fmt.pf ppf ")"
|
|
||||||
| CBR (v, 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_operand v l1 l2
|
Fmt.pf ppf "cbr %a, %s, %s" pp_reg a l1 l2
|
||||||
| RET -> Fmt.pf ppf "ret"
|
|
||||||
| JMP l -> Fmt.pf ppf "jmp %s" (label l)
|
|
||||||
|
|
||||||
let pp_program ppf pr =
|
let pp_program ppf prog =
|
||||||
let ep = pr.entrypoint in
|
let basic_blocks = ref [ prog.entry, "START" ] in
|
||||||
let basic_blocks = ref [ ep, "START" ] in
|
let work_list = ref [ prog.entry ] in
|
||||||
let work_list = ref [ ep ] in
|
|
||||||
let label bb =
|
let label bb =
|
||||||
try List.assq bb !basic_blocks
|
try List.assq bb !basic_blocks
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,3 @@
|
||||||
(library
|
(library
|
||||||
(name spice_runtime)
|
(name spice_runtime)
|
||||||
(libraries fmt))
|
(libraries spice_syntax fmt))
|
||||||
|
|
|
||||||
|
|
@ -3,170 +3,99 @@ exception Runtime_error of string
|
||||||
let runtime_error f =
|
let runtime_error f =
|
||||||
Fmt.kstr (fun s -> raise (Runtime_error s)) f
|
Fmt.kstr (fun s -> raise (Runtime_error s)) f
|
||||||
|
|
||||||
module Op = struct
|
module Prim = struct
|
||||||
let add v1 v2 =
|
let intop name ( ** ) v1 v2 =
|
||||||
match v1, v2 with
|
match v1, v2 with
|
||||||
| Value.Int x, Value.Int y -> Value.Int (Int64.add x y)
|
| Value.Int x, Value.Int y -> Value.Int (x ** y)
|
||||||
| _, _ -> runtime_error "cannot add non integer values"
|
| _, _ -> runtime_error "cannot %s non integer values" name
|
||||||
|
|
||||||
let sub v1 v2 =
|
let cmpop ( </> ) v1 v2 =
|
||||||
match v1, v2 with
|
match v1, v2 with
|
||||||
| Value.Int x, Value.Int y -> Value.Int (Int64.sub x y)
|
| Value.Int x, Value.Int y -> Value.of_bool (Int64.compare x y </> 0)
|
||||||
| _, _ -> 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)
|
|
||||||
| _, _ -> runtime_error "cannot compare non integer values"
|
| _, _ -> runtime_error "cannot compare non integer values"
|
||||||
|
|
||||||
let grt v1 v2 =
|
let add = intop "add" Int64.add
|
||||||
match v1, v2 with
|
let sub = intop "sub" Int64.sub
|
||||||
| Value.Int x, Value.Int y -> Value.bool (Int64.compare x y > 0)
|
let mul = intop "mul" Int64.mul
|
||||||
| _, _ -> runtime_error "cannot compare non integer values"
|
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
|
let loc obj name =
|
||||||
| Value.False | Value.Nil -> false
|
try
|
||||||
| _ -> true
|
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 get obj loc =
|
||||||
|
match obj, Value.to_elem loc with
|
||||||
let slt obj name =
|
| Value.Obj (_, s), Field i -> s.(i)
|
||||||
match obj with
|
| Value.Obj (_, _), Method _ -> failwith "Interp.Prim.get: TODO: fcf"
|
||||||
| 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"
|
|
||||||
| 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 el v =
|
let set obj loc v =
|
||||||
match obj, Value.to_elem el with
|
match obj, Value.to_elem loc with
|
||||||
| Value.Obj (_, slots), Field i -> slots.(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 el =
|
let mthd obj loc =
|
||||||
match obj, Value.to_elem el 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.Op.get: TODO: fcf calls"
|
| Value.Obj (_, _), Field _ -> failwith "Interp.Prim.mthd: TODO: fcf"
|
||||||
| exception Invalid_argument _ -> runtime_error "invalid index"
|
| exception Invalid_argument _ -> runtime_error "invalid index"
|
||||||
| _ ->
|
| _ ->
|
||||||
(* TODO: create vtable from primitive types *)
|
(* TODO: vtable of primitive types *)
|
||||||
runtime_error "call field of non-object"
|
runtime_error "call method of non-object"
|
||||||
end
|
end
|
||||||
|
|
||||||
type frame = {
|
type frame = {
|
||||||
regs : Value.t array;
|
r : Value.t array;
|
||||||
mutable pc : Code.ins list;
|
mutable pc : Code.ins list;
|
||||||
}
|
}
|
||||||
|
|
||||||
let eval fr = function
|
let jmp fr b = fr.pc <- Code.instructions b
|
||||||
| 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 rec exec fr = function
|
let exec ({ r; _ } as fr) = function
|
||||||
| Code.MOV (l, r) -> fr.regs.(l) <- eval fr r
|
| Code.LDI (R a, v) -> r.(a) <- v
|
||||||
| Code.ADD (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
|
| Code.LDR (R a, R b) -> r.(a) <- r.(b)
|
||||||
| Code.SUB (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
|
| Code.ADD (R a, R b, R c) -> r.(a) <- Prim.add r.(b) r.(c)
|
||||||
| Code.MUL (l, r) -> fr.regs.(l) <- Op.mul fr.regs.(l) (eval fr r)
|
| Code.SUB (R a, R b, R c) -> r.(a) <- Prim.sub r.(b) r.(c)
|
||||||
| Code.EQL (l, r) -> fr.regs.(l) <- Op.eql fr.regs.(l) (eval fr r)
|
| Code.MUL (R a, R b, R c) -> r.(a) <- Prim.mul r.(b) r.(c)
|
||||||
| Code.LST (l, r) -> fr.regs.(l) <- Op.lst fr.regs.(l) (eval fr r)
|
| Code.LST (R a, R b, R c) -> r.(a) <- Prim.lst r.(b) r.(c)
|
||||||
| Code.GRT (l, r) -> fr.regs.(l) <- Op.grt fr.regs.(l) (eval fr r)
|
| Code.GRT (R a, R b, R c) -> r.(a) <- Prim.grt r.(b) r.(c)
|
||||||
| Code.NOT l -> fr.regs.(l) <- Op.not fr.regs.(l)
|
| Code.NOT (R a, R b) -> r.(a) <- Prim.not r.(b)
|
||||||
| Code.CON (l, vt) -> fr.regs.(l) <- Value.make_obj vt
|
| Code.EQL (R a, R b, R c) -> r.(a) <- Prim.eql r.(b) r.(c)
|
||||||
| Code.SLT (o, e, nm) -> fr.regs.(e) <- Op.slt fr.regs.(o) nm
|
| Code.GET (R a, R b, R c) -> r.(a) <- Prim.get r.(b) r.(c)
|
||||||
| Code.GET (o, e) -> fr.regs.(e) <- Op.get fr.regs.(o) fr.regs.(e)
|
| Code.SET (R a, R b, R c) -> Prim.set r.(b) r.(c) r.(a)
|
||||||
| Code.SET (o, e) -> Op.set fr.regs.(o) fr.regs.(e) fr.regs.(e + 1)
|
| Code.LOC (R a, R b, el) -> r.(a) <- Prim.loc r.(b) el
|
||||||
| Code.RET -> fr.pc <- []
|
| Code.CON (R a, vtbl) -> r.(a) <- Value.make_obj vtbl
|
||||||
| Code.CLL (o, m, k) ->
|
| Code.JMP b -> jmp fr b
|
||||||
let self, mthd = Op.mthd fr.regs.(o) fr.regs.(m) in
|
| Code.CBR (R a, b1, b2) ->
|
||||||
let args = List.init k (fun i -> fr.regs.(m + i + 1)) in
|
jmp fr (if Value.truthy r.(a) then b1 else b2)
|
||||||
fr.regs.(m) <- call mthd self args
|
| Code.RET ->
|
||||||
| Code.JMP l -> fr.pc <- Code.instructions l
|
fr.pc <- []
|
||||||
| Code.CBR (v, l1, l2) ->
|
|
||||||
fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2)
|
|
||||||
|
|
||||||
and call mthd self args =
|
let rec step fr =
|
||||||
match mthd with
|
match fr.pc with
|
||||||
| Code.Method pr ->
|
| [] -> ()
|
||||||
if args <> [] then failwith "Interp.call: TODO: method arguments";
|
| i :: rest ->
|
||||||
run pr self
|
fr.pc <- rest;
|
||||||
| _ -> Value.call mthd self args
|
exec fr i;
|
||||||
|
step fr
|
||||||
|
|
||||||
and run prog self =
|
let run prog self =
|
||||||
let frame_size = 1 in
|
let r = Array.make (Code.frame_size prog) Value.Nil in
|
||||||
let frame_size = max frame_size (Code.frame_size prog) in
|
let fr = { r; pc = [] } in
|
||||||
let fr = {
|
r.(0) <- self;
|
||||||
regs = Array.make frame_size Value.Nil;
|
jmp fr prog.entry;
|
||||||
pc = Code.instructions prog.entrypoint;
|
step fr;
|
||||||
} in
|
r.(0)
|
||||||
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 ]
|
|
||||||
|
|
|
||||||
|
|
@ -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 = ..
|
and mthd = ..
|
||||||
|
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
| Nil
|
| Nil
|
||||||
| True
|
| True
|
||||||
|
|
@ -20,19 +21,34 @@ type t =
|
||||||
| Int of int64
|
| Int of int64
|
||||||
| Obj of vtable * t array
|
| 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
|
| true -> True
|
||||||
| false -> False
|
| 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 of_elem e =
|
||||||
let idx =
|
let idx =
|
||||||
match e with
|
match e with
|
||||||
| Field i -> i
|
| Field i -> i
|
||||||
| Method i -> -succ i
|
| Method i -> -succ i
|
||||||
in
|
in
|
||||||
Int (Int64.of_int idx)
|
of_int idx
|
||||||
|
|
||||||
let to_elem = function
|
let to_elem = function
|
||||||
| Int idx ->
|
| Int idx ->
|
||||||
|
|
@ -44,6 +60,21 @@ let to_elem = function
|
||||||
| _ ->
|
| _ ->
|
||||||
invalid_arg "to_elem: non integer value"
|
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
|
let rec pp ppf = function
|
||||||
| Obj (vtable, slots) -> pp_obj ppf vtable slots
|
| Obj (vtable, slots) -> pp_obj ppf vtable slots
|
||||||
| Int n -> Fmt.string ppf (Int64.to_string n)
|
| Int n -> Fmt.string ppf (Int64.to_string n)
|
||||||
|
|
@ -66,17 +97,3 @@ and pp_obj ppf vtable slots =
|
||||||
sep := ",")
|
sep := ",")
|
||||||
vtable.elems;
|
vtable.elems;
|
||||||
Fmt.pf ppf "}"
|
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 Code = Spice_runtime.Code
|
||||||
module Value = Spice_runtime.Value
|
module Value = Spice_runtime.Value
|
||||||
|
|
||||||
|
open Spice_syntax
|
||||||
|
open Spice_runtime
|
||||||
|
open Spice_compile
|
||||||
|
|
||||||
exception Error of string
|
exception Error of string
|
||||||
|
|
||||||
let failf f =
|
let failf f =
|
||||||
Fmt.kstr (fun s -> raise (Error s)) f
|
Fmt.kstr (fun s -> raise (Error s)) f
|
||||||
|
|
||||||
let parse input =
|
let parse input =
|
||||||
let open Spice_syntax in
|
|
||||||
let lexbuf = Lexing.from_string input ~with_positions:true in
|
let lexbuf = Lexing.from_string input ~with_positions:true in
|
||||||
try
|
try Parser.modl Lexer.read lexbuf
|
||||||
Parser.modl Lexer.read lexbuf
|
|
||||||
with
|
with
|
||||||
| Parser.Error -> failf "syntax error"
|
| Parser.Error -> failf "syntax error"
|
||||||
| Lexer.Error msg -> failf "syntax error: %s" msg
|
| 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 run prog =
|
||||||
let open Spice_runtime in
|
try Interp.run prog (Value.native_lib Std.lib)
|
||||||
try
|
with Interp.Runtime_error msg ->
|
||||||
let stdlib = Value.native_lib Interp.stdlib in
|
failf "runtime error: %s" msg
|
||||||
Interp.run prog stdlib
|
|
||||||
with
|
|
||||||
| Interp.Runtime_error msg -> failf "runtime error: %s" msg
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue