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

switch formatter to ocp-indent

This commit is contained in:
tali 2023-12-02 17:02:40 -05:00
parent d523c5c997
commit 333b8e7450
8 changed files with 204 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.ocp-indent Normal file
View File

@ -0,0 +1,12 @@
base = 2
type = 2
in = 0
with = 0
match_clause = 2
ppx_stritem_ext = 2
max_indent = 4
strict_with = never
strict_else = always
strict_comments = false
align_ops = true
align_params = always

3
format.sh Executable file
View File

@ -0,0 +1,3 @@
#!/usr/bin/env sh
git ls-tree HEAD -r --name-only | grep 'ml$' | xargs ocp-indent -i

129
lib/compile/bcc.ml
View File

@ -25,66 +25,61 @@ let compile modl =
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)
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
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)
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
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
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
@ -94,12 +89,13 @@ let compile modl =
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)
| 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
@ -107,9 +103,8 @@ let compile modl =
(* compile methods *)
let mthds = [||] in
let vtable = Value.{ n_slots; elems; 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
@ -121,18 +116,20 @@ let compile modl =
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)
| 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

79
lib/runtime/code.ml
View File

@ -17,8 +17,8 @@ let cst = function
type basic_block = {
mutable ins_builder : ins list;
mutable ins_list : ins list;
(* bc_pc : int *)
(* bc_len : int *)
(* bc_pc : int *)
(* bc_len : int *)
}
and ins =
@ -39,11 +39,15 @@ and ins =
| CBR of operand * basic_block * basic_block
| RET
let make_basic_block ins_list = { ins_builder = List.rev ins_list; ins_list }
let make_basic_block ins_list = {
ins_builder = List.rev ins_list;
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;
if bb.ins_list = [] then
bb.ins_list <- List.rev bb.ins_builder;
bb.ins_list
let add_ins bb is =
@ -55,7 +59,8 @@ let add_ins bb is =
type program = { entrypoint : basic_block }
type Value.mthd += Method of program
let make_program entrypoint = { entrypoint }
let make_program entrypoint =
{ entrypoint }
let frame_size prog =
let visited = ref [] in
@ -78,22 +83,22 @@ let frame_size prog =
| 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
enqueue b1;
enqueue b2;
op acc v
| CLL (o, m, k) -> reg (reg acc o) (m + k + 1)
| JMP b ->
enqueue b;
acc
enqueue b;
acc
| RET -> acc
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
visited := bb :: !visited;
work_list := rest;
List.fold_left ins acc (instructions bb) |> loop
in
loop 1
@ -113,10 +118,10 @@ let pp_vtable ppf vt =
let sep = ref "" in
Hashtbl.iter
(fun name -> function
| Value.Method _ -> ()
| Value.Field idx ->
Fmt.pf ppf "%s%s@%d" !sep name idx;
sep := ";")
| Value.Method _ -> ()
| Value.Field idx ->
Fmt.pf ppf "%s%s@%d" !sep name idx;
sep := ";")
vt.elems;
Fmt.pf ppf "}"
@ -134,16 +139,16 @@ let pp_ins ~label ppf = function
| 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 ")"
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) ->
let l1 = label b1 in
let l2 = label b2 in
Fmt.pf ppf "cbr %a, %s, %s" pp_operand v l1 l2
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)
@ -163,17 +168,17 @@ let pp_program ppf pr =
match !work_list with
| [] -> ()
| bb :: rest ->
work_list := rest;
if i > 0 then Fmt.pf ppf ",";
Fmt.pf ppf "%S:[" (label bb);
List.iteri
(fun i is ->
if i > 0 then Fmt.pf ppf ",";
let str = Fmt.str "%a" (pp_ins ~label) is in
Fmt.pf ppf "%S" str)
(instructions bb);
Fmt.pf ppf "]";
loop (i + 1)
work_list := rest;
if i > 0 then Fmt.pf ppf ",";
Fmt.pf ppf "%S:[" (label bb);
List.iteri
(fun i is ->
if i > 0 then Fmt.pf ppf ",";
let str = Fmt.str "%a" (pp_ins ~label) is in
Fmt.pf ppf "%S" str)
(instructions bb);
Fmt.pf ppf "]";
loop (i + 1)
in
Fmt.pf ppf "{";
loop 0;

72
lib/runtime/interp.ml
View File

@ -1,6 +1,7 @@
exception Runtime_error of string
let runtime_error f = Fmt.kstr (fun s -> raise (Runtime_error s)) f
let runtime_error f =
Fmt.kstr (fun s -> raise (Runtime_error s)) f
module Op = struct
let add v1 v2 =
@ -41,9 +42,11 @@ module Op = struct
let slt obj name =
match obj with
| Value.Obj (vtable, _) -> (
| Value.Obj (vtable, _) ->
begin
try Value.of_elem (Hashtbl.find vtable.elems name)
with Not_found -> runtime_error "no such element %S" name)
with Not_found -> runtime_error "no such element %S" name
end
| _ -> runtime_error "get element of non-object"
let get obj el =
@ -66,8 +69,8 @@ module Op = struct
| Value.Obj (_, _), Field _ -> failwith "Interp.Op.get: TODO: fcf calls"
| exception Invalid_argument _ -> runtime_error "invalid index"
| _ ->
(* TODO: create vtable from primitive types *)
runtime_error "call field of non-object"
(* TODO: create vtable from primitive types *)
runtime_error "call field of non-object"
end
type frame = {
@ -97,35 +100,34 @@ let rec exec fr = function
| 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
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)
fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2)
and call mthd self args =
match mthd with
| Code.Method pr ->
if args <> [] then failwith "Interp.call: TODO: method arguments";
run pr self
if args <> [] then failwith "Interp.call: TODO: method arguments";
run pr self
| _ -> Value.call mthd self args
and run prog self =
let frame_size = 1 in
let frame_size = max frame_size (Code.frame_size prog) in
let fr =
let regs = Array.make frame_size Value.Nil in
let pc = Code.instructions prog.entrypoint in
{ regs; pc }
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 ()
fr.pc <- rest;
exec fr ins;
run_loop ()
in
fr.regs.(0) <- self;
run_loop ();
@ -136,8 +138,8 @@ let stdlib =
let pp ppf vs =
List.iteri
(fun i v ->
if i > 0 then Fmt.pf ppf " ";
Value.pp ppf v)
if i > 0 then Fmt.pf ppf " ";
Value.pp ppf v)
vs
in
Fmt.pr "%a\n" pp vs;
@ -147,24 +149,24 @@ let stdlib =
| [] -> 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
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
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 ]

21
lib/runtime/value.ml
View File

@ -36,9 +36,13 @@ let of_elem e =
let to_elem = function
| Int idx ->
let i = Int64.to_int idx in
if i >= 0 then Field i else Method (-succ i)
| _ -> invalid_arg "to_elem: non integer value"
let i = Int64.to_int idx in
if i >= 0 then
Field i
else
Method (-succ i)
| _ ->
invalid_arg "to_elem: non integer value"
let rec pp ppf = function
| Obj (vtable, slots) -> pp_obj ppf vtable slots
@ -56,10 +60,10 @@ and pp_obj ppf vtable slots =
let sep = ref "" in
Hashtbl.iter
(fun name -> function
| Method _ -> ()
| Field idx ->
Fmt.pf ppf "%s%S:%a" !sep name pp slots.(idx);
sep := ",")
| Method _ -> ()
| Field idx ->
Fmt.pf ppf "%s%S:%a" !sep name pp slots.(idx);
sep := ",")
vtable.elems;
Fmt.pf ppf "}"
@ -73,7 +77,6 @@ let call mthd _self args =
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 in
let mthds = Array.of_list mthds in
let mthds = List.map (fun (_, f) -> Native_function f) fns |> Array.of_list in
let vtable = { n_slots = 0; elems; mthds } in
Obj (vtable, [||])

17
lib/spice.ml
View File

@ -4,19 +4,24 @@ module Value = Spice_runtime.Value
exception Error of string
let failf f = Fmt.kstr (fun s -> raise (Error s)) f
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 Spice_syntax.Parser.modl Spice_syntax.Lexer.read lexbuf with
| Spice_syntax.Parser.Error -> failf "syntax error"
| Spice_syntax.Lexer.Error msg -> failf "syntax error: %s" msg
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 run prog =
let open Spice_runtime in
try
let open Spice_runtime in
let stdlib = Value.native_lib Interp.stdlib in
Interp.run prog stdlib
with Spice_runtime.Interp.Runtime_error msg -> failf "runtime error: %s" msg
with
| Interp.Runtime_error msg -> failf "runtime error: %s" msg

47
lib/syntax/ast.ml
View File

@ -70,8 +70,8 @@ let pp_list pp_ele ppf list =
Fmt.pf ppf "[";
List.iteri
(fun i ele ->
if i > 0 then Fmt.pf ppf ",";
pp_ele ppf ele)
if i > 0 then Fmt.pf ppf ",";
pp_ele ppf ele)
list;
Fmt.pf ppf "]"
@ -82,34 +82,35 @@ let rec pp_exp ppf = function
| Path (Ele (e, x)) -> Fmt.pf ppf "{\"ele\":%a,\"field\":%S}" pp_exp e x
| Call (fn, args) -> Fmt.pf ppf "{\"call\":%a}" (pp_list pp_exp) (Path fn :: args)
| If (ec, et, ee) ->
Fmt.pf ppf "{\"if\":%a,\"then\":%a,\"else\":%a}" pp_exp ec pp_exp et pp_exp ee
Fmt.pf ppf "{\"if\":%a,\"then\":%a,\"else\":%a}"
pp_exp ec
pp_exp et
pp_exp ee
| Binop (op, e1, e2) ->
Fmt.pf
ppf
"{\"binop\":%S,\"lhs\":%a,\"rhs\":%a}"
(string_of_binop op)
pp_exp
e1
pp_exp
e2
Fmt.pf ppf "{\"binop\":%S,\"lhs\":%a,\"rhs\":%a}"
(string_of_binop op)
pp_exp e1
pp_exp e2
| Fun (params, body) ->
Fmt.pf ppf "{\"fun\":%a,\"body\":%a}" (pp_list Fmt.string) params pp_exp body
Fmt.pf ppf "{\"fun\":%a,\"body\":%a}"
(pp_list Fmt.string) params
pp_exp body
| Obj body -> Fmt.pf ppf "{\"obj\":%a}" (pp_list pp_item) body
| Scope body -> Fmt.pf ppf "{\"scope\":%a}" (pp_list pp_item) body
and pp_item ppf = function
| Item_exp e -> Fmt.pf ppf "{\"exp\":%a}" pp_exp e
| Item_val (name, rhs) -> Fmt.pf ppf "{\"val\":%S,\"rhs\":%a}" name pp_exp rhs
| Item_exp e ->
Fmt.pf ppf "{\"exp\":%a}" pp_exp e
| Item_val (name, rhs) ->
Fmt.pf ppf "{\"val\":%S,\"rhs\":%a}" name pp_exp rhs
| Item_fun (name, params, body) ->
Fmt.pf
ppf
"{\"fun\":%S,\"params\":%a,\"body\":%a}"
name
(pp_list Fmt.string)
params
pp_exp
body
Fmt.pf ppf "{\"fun\":%S,\"params\":%a,\"body\":%a}"
name
(pp_list Fmt.string) params
pp_exp body
| Item_obj (name, body) ->
Fmt.pf ppf "{\"obj\":%S,\"body\":%a}" name (pp_list pp_item) body
Fmt.pf ppf "{\"obj\":%S,\"body\":%a}"
name
(pp_list pp_item) body
let pp_modl ppf m = pp_list pp_item ppf m.items