big clean up of Code, Interp, removed all of Bcc

This commit is contained in:
tali 2023-12-06 20:30:42 -05:00
parent ec9dffc780
commit c51b482607
7 changed files with 263 additions and 437 deletions

View File

@ -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 }

View File

@ -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 ->

View File

@ -1,3 +1,3 @@
(library
(name spice_runtime)
(libraries fmt))
(libraries spice_syntax fmt))

View File

@ -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)

39
lib/runtime/std.ml Normal file
View File

@ -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;
]

View File

@ -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, [||])

View File

@ -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