From 333b8e7450fdf13634f59a7649d0ff099529a965 Mon Sep 17 00:00:00 2001 From: tali Date: Sat, 2 Dec 2023 17:02:40 -0500 Subject: [PATCH] switch formatter to ocp-indent --- .ocp-indent | 12 ++++ format.sh | 3 + lib/compile/bcc.ml | 129 +++++++++++++++++++++--------------------- lib/runtime/code.ml | 79 ++++++++++++++------------ lib/runtime/interp.ml | 72 +++++++++++------------ lib/runtime/value.ml | 21 ++++--- lib/spice.ml | 17 ++++-- lib/syntax/ast.ml | 47 +++++++-------- 8 files changed, 204 insertions(+), 176 deletions(-) create mode 100644 .ocp-indent create mode 100755 format.sh diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 0000000..a38ac7b --- /dev/null +++ b/.ocp-indent @@ -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 diff --git a/format.sh b/format.sh new file mode 100755 index 0000000..7fcee61 --- /dev/null +++ b/format.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env sh + +git ls-tree HEAD -r --name-only | grep 'ml$' | xargs ocp-indent -i diff --git a/lib/compile/bcc.ml b/lib/compile/bcc.ml index 11e7a1a..a668487 100644 --- a/lib/compile/bcc.ml +++ b/lib/compile/bcc.ml @@ -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 diff --git a/lib/runtime/code.ml b/lib/runtime/code.ml index 2792a66..92e7257 100644 --- a/lib/runtime/code.ml +++ b/lib/runtime/code.ml @@ -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; diff --git a/lib/runtime/interp.ml b/lib/runtime/interp.ml index ace9136..20cbbce 100644 --- a/lib/runtime/interp.ml +++ b/lib/runtime/interp.ml @@ -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 ] diff --git a/lib/runtime/value.ml b/lib/runtime/value.ml index d922a8c..b3808ee 100644 --- a/lib/runtime/value.ml +++ b/lib/runtime/value.ml @@ -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, [||]) diff --git a/lib/spice.ml b/lib/spice.ml index ed1d8ed..3952b1f 100644 --- a/lib/spice.ml +++ b/lib/spice.ml @@ -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 diff --git a/lib/syntax/ast.ml b/lib/syntax/ast.ml index 5878076..c8adee0 100644 --- a/lib/syntax/ast.ml +++ b/lib/syntax/ast.ml @@ -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