refactor handling slot/method indices
This commit is contained in:
parent
24409f7902
commit
0460e6b646
|
|
@ -48,7 +48,6 @@ let add_ins bb is =
|
|||
bb.ins_list <- []
|
||||
|
||||
type program = { entrypoint : basic_block }
|
||||
|
||||
type Value.mthd += Method of program
|
||||
|
||||
let make_program entrypoint = { entrypoint }
|
||||
|
|
|
|||
|
|
@ -1,20 +1,22 @@
|
|||
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 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.Int (Int64.add x y)
|
||||
| _, _ -> raise (Runtime_error "cannot add non integer values")
|
||||
| _, _ -> runtime_error "cannot add non integer values"
|
||||
|
||||
let sub v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.Int (Int64.sub x y)
|
||||
| _, _ -> raise (Runtime_error "cannot sub non integer values")
|
||||
| _, _ -> 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)
|
||||
| _, _ -> raise (Runtime_error "cannot mul non integer values")
|
||||
| _, _ -> runtime_error "cannot mul non integer values"
|
||||
|
||||
let eql v1 v2 =
|
||||
match v1, v2 with
|
||||
|
|
@ -24,12 +26,12 @@ module Op = struct
|
|||
let lst v1 v2 =
|
||||
match v1, v2 with
|
||||
| Value.Int x, Value.Int y -> Value.bool (Int64.compare x y < 0)
|
||||
| _, _ -> raise (Runtime_error "cannot compare non integer values")
|
||||
| _, _ -> 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)
|
||||
| _, _ -> raise (Runtime_error "cannot compare non integer values")
|
||||
| _, _ -> runtime_error "cannot compare non integer values"
|
||||
|
||||
let is_truthy = function
|
||||
| Value.False | Value.Nil -> false
|
||||
|
|
@ -37,39 +39,35 @@ module Op = struct
|
|||
|
||||
let not v = Value.bool (not (is_truthy v))
|
||||
|
||||
let slt o nm =
|
||||
match o with
|
||||
let slt obj name =
|
||||
match obj 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")
|
||||
try Value.of_elem (Hashtbl.find vtable.elems name)
|
||||
with Not_found -> runtime_error "no such element %S" name)
|
||||
| _ -> runtime_error "get element of non-object"
|
||||
|
||||
let get o s =
|
||||
match o, s with
|
||||
| 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 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"
|
||||
| _ -> 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 set obj el v =
|
||||
match obj, Value.to_elem el with
|
||||
| Value.Obj (_, slots), Field i -> slots.(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 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")
|
||||
let mthd obj el =
|
||||
match obj, Value.to_elem el with
|
||||
| Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i)
|
||||
| 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"
|
||||
end
|
||||
|
||||
type frame = {
|
||||
|
|
@ -102,9 +100,9 @@ let rec 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.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
|
||||
|
|
@ -114,13 +112,12 @@ let rec exec fr = function
|
|||
| 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 = match mthd with
|
||||
and call mthd self args =
|
||||
match mthd with
|
||||
| Code.Method pr ->
|
||||
if args <> [] then
|
||||
failwith "Interp.call: TODO: method arguments";
|
||||
if args <> [] then failwith "Interp.call: TODO: method arguments";
|
||||
run_program pr
|
||||
| _ ->
|
||||
Value.call mthd self args
|
||||
| _ -> Value.call mthd self args
|
||||
|
||||
and run fr =
|
||||
match fr.pc with
|
||||
|
|
|
|||
|
|
@ -21,12 +21,25 @@ 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
|
||||
| false -> False
|
||||
|
||||
let of_elem e =
|
||||
let idx =
|
||||
match e with
|
||||
| Field i -> i
|
||||
| Method i -> -succ i
|
||||
in
|
||||
Int (Int64.of_int idx)
|
||||
|
||||
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 rec pp ppf = function
|
||||
| Obj (vtable, slots) -> pp_obj ppf vtable slots
|
||||
| Int n -> Fmt.string ppf (Int64.to_string n)
|
||||
|
|
@ -50,9 +63,9 @@ and pp_obj ppf vtable slots =
|
|||
vtable.elems;
|
||||
Fmt.pf ppf "}"
|
||||
|
||||
type mthd +=
|
||||
| Native_function of (t -> t list -> t)
|
||||
type mthd += Native_function of (t -> t list -> t)
|
||||
|
||||
let call mthd self args = match mthd with
|
||||
let call mthd self args =
|
||||
match mthd with
|
||||
| Native_function f -> f self args
|
||||
| _ -> raise Not_found
|
||||
|
|
|
|||
Loading…
Reference in New Issue