From 24409f7902bdd96149a3d5db201a8cb0b8ba5ce3 Mon Sep 17 00:00:00 2001 From: tali Date: Sat, 2 Dec 2023 13:51:15 -0500 Subject: [PATCH] add named fields and preliminary method support --- bin/main.ml | 2 +- lib/compile/bcc.ml | 11 +++++++++- lib/runtime/code.ml | 19 +++++++++++++--- lib/runtime/interp.ml | 51 +++++++++++++++++++++++++++++++++++++------ lib/runtime/value.ml | 24 ++++++++++++-------- 5 files changed, 86 insertions(+), 21 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index d772212..1be7810 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -5,7 +5,7 @@ let () = Logs.set_level (Some Logs.Debug); try - let ast = parse "val z = 5 val output = 1 + (({ val x = 3 val y = 4 x * y }) + z)" in + let ast = parse "obj pos { val x = 3 val y = 4 } val result = pos.x" in let prog = compile ast in let ret = run prog in Fmt.pr "{\"program\":%a,\"output\":%a}" Code.pp_program prog Value.pp ret diff --git a/lib/compile/bcc.ml b/lib/compile/bcc.ml index 935723c..e4ac101 100644 --- a/lib/compile/bcc.ml +++ b/lib/compile/bcc.ml @@ -27,6 +27,11 @@ let compile modl = emit_mov sp (Code.cst_of_int slot); 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.Binop (op, lhs, rhs) -> let lhs = compile_exp env sp lhs in emit_mov sp lhs; @@ -83,7 +88,11 @@ let compile modl = (env, 0) items in - let vtable = Value.{ elems; n_slots } in + + (* compile methods *) + let mthds = [||] in + + let vtable = Value.{ n_slots; elems; mthds } in (* emit constructor, compile val fields, and get result of final expression *) emit (CON (self, vtable)); diff --git a/lib/runtime/code.ml b/lib/runtime/code.ml index 324fdbb..d104953 100644 --- a/lib/runtime/code.ml +++ b/lib/runtime/code.ml @@ -26,8 +26,10 @@ and ins = | 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 | RET @@ -47,6 +49,8 @@ let add_ins bb is = type program = { entrypoint : basic_block } +type Value.mthd += Method of program + let make_program entrypoint = { entrypoint } let frame_size prog = @@ -67,12 +71,13 @@ let frame_size prog = | LST (r, v) | GRT (r, v) -> op (reg acc r) v | CON (r, _) | NOT r -> reg acc r - | GET (o, v) -> reg (reg acc o) v - | SET (o, v) -> reg (reg acc o) (v + 1) + | 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) | JMP b -> enqueue b; acc @@ -104,7 +109,7 @@ let pp_vtable ppf vt = let sep = ref "" in Hashtbl.iter (fun name -> function - | Value.Method -> () + | Value.Method _ -> () | Value.Field idx -> Fmt.pf ppf "%s%s@%d" !sep name idx; sep := ";") @@ -121,8 +126,16 @@ let pp_ins ~label ppf = function | 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](" 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 diff --git a/lib/runtime/interp.ml b/lib/runtime/interp.ml index 485a602..1211727 100644 --- a/lib/runtime/interp.ml +++ b/lib/runtime/interp.ml @@ -31,21 +31,45 @@ module Op = struct | Value.Int x, Value.Int y -> Value.bool (Int64.compare x y > 0) | _, _ -> raise (Runtime_error "cannot compare non integer values") - let truthy = function + let is_truthy = function | Value.False | Value.Nil -> false | _ -> true - let not v = Value.bool (not (truthy v)) + let not v = Value.bool (not (is_truthy v)) + + let slt o nm = + match o with + | Value.Obj (vtable, _) -> ( + match Hashtbl.find vtable.elems nm with + | Value.Field i -> Value.int i + | Value.Method i -> Value.int (-succ i) + | exception Not_found -> raise (Runtime_error (Fmt.str "no method %S" nm))) + | _ -> raise (Runtime_error "get element of non-object") let get o s = match o, s with - | Value.Obj (_, slots), Value.Int i -> slots.(Int64.to_int i) + | Value.Obj (_, slots), Value.Int i -> + let i = Int64.to_int i in + if i < 0 then + failwith "Interp.Op.get: TODO: method reification" + else + slots.(i) | _ -> raise (Runtime_error "get field of non-object") let set o s v = match o, s with | Value.Obj (_, slots), Value.Int i -> slots.(Int64.to_int i) <- v | _ -> raise (Runtime_error "set field of non-object") + + let mthd o s = + match o, s with + | Value.Obj (vtable, _), Value.Int i -> + let i = Int64.to_int i in + if i < 0 then + o, vtable.mthds.(-succ i) + else + failwith "Interp.Op.get: first class function calls" + | _ -> raise (Runtime_error "call method of non-object") end type frame = { @@ -68,7 +92,7 @@ let eval fr = function | Code.Cst_int n -> Value.Int n | Code.Reg i -> fr.regs.(i) -let exec fr = function +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) @@ -78,14 +102,27 @@ let exec fr = function | 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, s, nm) -> fr.regs.(s) <- Op.slt fr.regs.(o) nm | Code.GET (o, s) -> fr.regs.(s) <- Op.get fr.regs.(o) fr.regs.(s) | Code.SET (o, s) -> Op.set fr.regs.(o) fr.regs.(s) fr.regs.(s + 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.truthy (eval fr v) then l1 else l2) + fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2) -let rec run fr = +and call mthd self args = match mthd with + | Code.Method pr -> + if args <> [] then + failwith "Interp.call: TODO: method arguments"; + run_program pr + | _ -> + Value.call mthd self args + +and run fr = match fr.pc with | [] -> return_value fr | is :: rest -> @@ -93,4 +130,4 @@ let rec run fr = exec fr is; run fr -let run_program pr = run (make_frame pr) +and run_program pr = run (make_frame pr) diff --git a/lib/runtime/value.ml b/lib/runtime/value.ml index 1a36862..ce35f1e 100644 --- a/lib/runtime/value.ml +++ b/lib/runtime/value.ml @@ -1,19 +1,17 @@ +type slotidx = int +type mthdidx = int + type vtable = { n_slots : int; elems : (string, elem) Hashtbl.t; + mthds : mthd array; } -and slotidx = int - and elem = | Field of slotidx - | Method (* of callable *) + | Method of mthdidx -let make_vtable fields = - { - n_slots = List.length fields; - elems = List.to_seq fields |> Seq.mapi (fun i name -> name, Field i) |> Hashtbl.of_seq; - } +and mthd = .. type t = | Nil @@ -23,6 +21,7 @@ type t = | Obj of vtable * t array let make_obj vtable = Obj (vtable, Array.make vtable.n_slots Nil) +let int n = Int (Int64.of_int n) let bool = function | true -> True @@ -44,9 +43,16 @@ and pp_obj ppf vtable slots = let sep = ref "" in Hashtbl.iter (fun name -> function - | Method -> () + | Method _ -> () | Field idx -> Fmt.pf ppf "%s%S:%a" !sep name pp slots.(idx); sep := ",") vtable.elems; Fmt.pf ppf "}" + +type mthd += + | Native_function of (t -> t list -> t) + +let call mthd self args = match mthd with + | Native_function f -> f self args + | _ -> raise Not_found