Ekdohibs/camlboot
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

support object-oriented features

Browse Source 
We need to support the object-oriented code that can be found in the
native backend.
This commit is contained in:
Gabriel Scherer 2019-08-17 15:37:30 +02:00 committed by Nathanaël Courant
parent b89e68967c
commit 9bbf49d906
6 changed files with 412 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
data.ml
View File

@ -63,6 +63,7 @@ and value_ =
| Lz of (unit -> value) ref
| Array of value array
| Fun_with_extra_args of value * value list * (arg_label * value) SMap.t
| Object of object_value
and fexpr = Location.t -> (arg_label * expression) list -> expression option
@ -72,10 +73,18 @@ and 'a env_map = (bool * 'a) SMap.t
and env =
{ units : module_unit_state UStore.t;
values : value env_map;
values : value_or_lvar env_map;
modules : mdl env_map;
constructors : int env_map;
}
classes : class_def env_map;
current_object : object_value option;
}
and value_or_lvar =
| Value of value
| Instance_variable of object_value * string
and class_def = class_expr * env ref
and mdl =
| Unit of module_unit_id
@ -86,6 +95,7 @@ and mdl_val = {
mod_values : value SMap.t;
mod_modules : mdl SMap.t;
mod_constructors : int SMap.t;
mod_classes : class_def SMap.t;
}
and module_unit_state =
@ -133,6 +143,54 @@ and module_unit_state =
value.
*)
and object_value = {
env: env;
self: pattern;
initializers: expr_in_object list;
named_parents: object_value SMap.t;
variables: value ref SMap.t;
methods: expr_in_object SMap.t;
parent_view: string list;
(* When evaluating a call super#foo, it would be wrong to just
resolve the call in a parent object bound to the 'super'
identifier in the current environment. Indeed, when then
executing the code of super#foo, self-calls of the form self#bar
would be resolved in the parent object 'super', instead of in the
current object 'self', which is the intended late-binding
semantics.
To solve this issue, we bind 'super' not to the parent object,
but to the *current* object "viewed as its parent 'super'"; the
'parent_view' field stores that view (in general there may be
several levels of super-calls nesting, so it's a list). The view
affects how methods are resolved -- their code is looked up
in the right parent object.
*)
}
and source_object =
| Current_object
| Parent of object_value
and expr_in_object = {
source : source_object;
instance_variable_scope : SSet.t;
(** The scoping of instance variables within object declarations
makes them in the scope of only some of the expressions in methods
and initializers; an "instance variable scope" remembers the set
of instance variables that are in scope of a given expression). *)
named_parents_scope : SSet.t;
(** Similarly, it may be that only some of the 'inherit foo as x' fields
scope over the current piece of code, so we keep a set of visible parents.
Remark: the self-pattern is always at the beginning of a class
or object declaration, so it is in the scope of all
expressions. *)
expr : expression;
}
exception InternalException of value
let unit = ptr @@ Constructor ("()", 0, None)
@ -178,6 +236,7 @@ let rec pp_print_value ff = onptr @@ function
~pp_sep:(fun ff () -> Format.fprintf ff "; ")
pp_print_value)
(Array.to_list a)
| Object _ -> Format.fprintf ff "<object>"
let pp_print_unit_id ppf (Path s) =
Format.fprintf ppf "%S" s
@ -244,6 +303,7 @@ let rec value_compare v1 v2 = match Ptr.get v1, Ptr.get v2 with
failwith "tried to compare channel"
| Fexpr _, _ | _, Fexpr _ -> failwith "tried to compare fexpr"
| Prim _, _ | _, Prim _ -> failwith "tried to compare prim"
| Object _, _ | _, Object _ -> failwith "tried to compare object"
| Int n1, Int n2 -> compare n1 n2
| Int _, _ -> assert false

38
envir.ml
View File

@ -7,10 +7,19 @@ let empty_env =
units = UStore.empty;
modules = SMap.empty;
constructors = SMap.empty;
classes = SMap.empty;
current_object = None;
}
let env_set_value key v env =
{ env with values = SMap.add key (true, v) env.values }
{ env with values = SMap.add key (true, Value v) env.values }
let env_set_lvar lvar obj env =
{ env with values =
SMap.add lvar (false, Instance_variable (obj, lvar)) env.values }
let env_set_instance_variable key obj v env =
{ env with values = SMap.add key (true, Instance_variable (obj, v)) env.values }
let env_set_module key m env =
{ env with modules = SMap.add key (true, m) env.modules }
@ -18,14 +27,20 @@ let env_set_module key m env =
let env_set_constr key c env =
{ env with constructors = SMap.add key (true, c) env.constructors }
let env_set_class key cl env =
{ env with classes = SMap.add key (true, cl) env.classes }
let env_extend exported env1 data =
let merge s1 s2 =
SMap.fold (fun k v env -> SMap.add k (exported, v) env) s2 s1
in
let values s = SMap.map (fun v -> Value v) s in
{ units = env1.units;
values = merge env1.values data.mod_values;
values = merge env1.values (values data.mod_values);
modules = merge env1.modules data.mod_modules;
constructors = merge env1.constructors data.mod_constructors;
classes = merge env1.classes data.mod_classes;
current_object = env1.current_object;
}
let declare_unit env unit_path =
@ -63,10 +78,19 @@ let make_module_data env =
let exported env_map =
env_map |> SMap.filter (fun _ (b, _) -> b) |> SMap.map snd
in
let values env_map =
env_map
|> SMap.filter (fun _ -> function
| Value v -> true
| Instance_variable _ -> false)
|> SMap.map (function
| Value v -> v
| Instance_variable _ -> assert false) in
{
mod_values = exported env.values;
mod_values = values (exported env.values);
mod_modules = exported env.modules;
mod_constructors = exported env.constructors;
mod_classes = exported env.classes;
}
let prevent_export env =
@ -75,6 +99,8 @@ let prevent_export env =
units = env.units;
modules = prevent env.modules;
constructors = prevent env.constructors;
classes = prevent env.classes;
current_object = env.current_object;
}
let decompose get_module_data env { txt = lident; loc } =
@ -103,7 +129,7 @@ let rec env_get_module env ({ loc; _ } as lid) =
let env_name, env, id = decompose env_get_module_data env lid in
lookup "module" ~env_name env.modules { txt = id; loc }
and env_get_value env ({ loc; _ } as lid) =
and env_get_value_or_lvar env ({ loc; _ } as lid) =
let env_name, env, id = decompose env_get_module_data env lid in
lookup "value" ~env_name env.values { txt = id; loc }
@ -111,5 +137,9 @@ and env_get_constr env ({ loc; _ } as lid) =
let env_name, env, id = decompose env_get_module_data env lid in
lookup "constructor" ~env_name env.constructors { txt = id; loc }
and env_get_class env ({ loc; _ } as lid) =
let env_name, env, id = decompose env_get_module_data env lid in
lookup "class" ~env_name env.classes { txt = id; loc }
and env_get_module_data env ({ loc; _ } as id) =
get_module_data env loc (env_get_module env id)

302
eval.ml
View File

@ -33,6 +33,11 @@ let unsupported loc =
Format.eprintf "%a: unsupported@."
Location.print_loc loc
let rec take n li = match n, li with
| 0, _ -> []
| _, [] -> invalid_arg "List.take"
| n, x::xs -> x :: take (n - 1) xs
let rec apply prims vf args =
let vf, extral, extram =
match Ptr.get vf with
@ -146,7 +151,13 @@ let rec apply prims vf args =
and eval_expr prims env expr =
match expr.pexp_desc with
| Pexp_ident id -> env_get_value env id
| Pexp_ident id ->
begin match env_get_value_or_lvar env id with
| Value v -> v
| Instance_variable (obj, name) ->
let var = SMap.find name obj.variables in
!var
end
| Pexp_constant c -> value_of_constant c
| Pexp_let (recflag, vals, e) ->
eval_expr prims (eval_bindings prims env recflag vals) e
@ -269,10 +280,31 @@ and eval_expr prims env expr =
unit
| _ -> mismatch expr.pexp_loc; assert false)
| Pexp_array l -> ptr @@ Array (Array.of_list (List.map (eval_expr prims env) l))
| Pexp_send _ -> unsupported expr.pexp_loc; assert false
| Pexp_new _ -> unsupported expr.pexp_loc; assert false
| Pexp_setinstvar _ -> unsupported expr.pexp_loc; assert false
| Pexp_override _ -> unsupported expr.pexp_loc; assert false
| Pexp_send (obj_expr, meth) ->
let obj = eval_expr prims env obj_expr in
(match Ptr.get obj with
| Object obj -> eval_obj_send expr.pexp_loc prims obj meth
| _ -> mismatch expr.pexp_loc; assert false)
| Pexp_new lid ->
let (class_expr, class_env) = env_get_class env lid in
eval_obj_new prims !class_env class_expr
| Pexp_setinstvar (x, e) ->
let v = eval_expr prims env e in
let x = { x with Location.txt = Longident.Lident x.txt } in
begin match env_get_value_or_lvar env x with
| Value _ -> mismatch expr.pexp_loc; assert false
| Instance_variable (obj, name) ->
let var = SMap.find name obj.variables in
var := v;
end;
Runtime_base.wrap_unit ()
| Pexp_override fields ->
begin match env.current_object with
| None -> mismatch expr.pexp_loc; assert false
| Some obj ->
let new_obj = eval_obj_override prims env obj fields in
ptr @@ Object new_obj
end
| Pexp_letexception ({ pext_name = name; pext_kind = k; _ }, e) ->
let nenv =
match k with
@ -299,7 +331,7 @@ and eval_expr prims env expr =
(InternalException
(Runtime_base.assert_failure_exn pos_fname pos_lnum pos_cnum)))
| Pexp_lazy e -> ptr @@ Lz (ref (fun () -> eval_expr prims env e))
| Pexp_poly _ -> assert false
| Pexp_poly (e, _ty) -> eval_expr prims env e
| Pexp_newtype (_, e) -> eval_expr prims env e
| Pexp_open (_, lident, e) ->
let nenv =
@ -375,7 +407,9 @@ and pattern_bind prims env pat v =
let lid =
Longident.(Ldot (Lident "CamlinternalFormat", "fmt_ebb_of_string"))
in
env_get_value env { loc = c.loc; txt = lid }
match env_get_value_or_lvar env { loc = c.loc; txt = lid } with
| Instance_variable _ -> assert false
| Value v -> v
in
let fmt = apply prims fmt_ebb_of_string [ (Nolabel, ptr @@ String s) ] in
let fmt =
@ -449,6 +483,248 @@ and eval_match prims env cl arg =
then eval_expr prims nenv c.pc_rhs
else eval_match prims env cl arg)
and lookup_viewed_object obj =
let rec lookup obj = function
| [] -> obj
| parent :: parent_view ->
lookup (SMap.find parent obj.named_parents) parent_view
in lookup obj obj.parent_view
and eval_expr_in_object prims obj expr_in_object =
let expr_env = match expr_in_object.source with
| Parent parent -> parent.env
| Current_object -> (lookup_viewed_object obj).env
in
let bind_self obj env =
let self_view = { obj with parent_view = [] } in
let self_pattern = match expr_in_object.source with
| Parent parent -> parent.self
| Current_object -> (lookup_viewed_object obj).self in
pattern_bind prims env self_pattern (ptr @@ Object self_view) in
let add_parent obj name env =
let parent_view =
{ obj with parent_view = name :: obj.parent_view } in
env_set_value name (ptr @@ Object parent_view) env in
let add_variable name env =
env_set_lvar name obj env in
let activate_object obj env =
{ env with current_object = Some obj } in
let env =
expr_env
|> bind_self obj
|> SSet.fold (add_parent obj) expr_in_object.named_parents_scope
|> SSet.fold add_variable expr_in_object.instance_variable_scope
|> activate_object obj
in
eval_expr prims env expr_in_object.expr
and eval_obj_send loc prims obj meth =
match SMap.find meth.txt (lookup_viewed_object obj).methods with
| exception Not_found ->
mismatch loc; assert false
| expr_in_object ->
eval_expr_in_object prims obj expr_in_object
and eval_obj_override prims env obj fields =
let override_field (x, e) obj =
let v = eval_expr prims env e in
{ obj with variables = SMap.add x.txt (ref v) obj.variables } in
let obj = List.fold_right override_field fields obj in
obj
and eval_class_expr prims env class_expr =
(* To avoid redundancy we express evaluation of class expressions by
rewriting the non-base cases into usual expressions (fun => fun,
etc.). For example
new (fun x -> <clexp>)
=>
fun x -> new <clexp>
*)
let eval_as_exp exp_desc =
eval_expr prims env {
pexp_desc = exp_desc;
pexp_loc = class_expr.pcl_loc;
pexp_attributes = class_expr.pcl_attributes;
} in
let new_ class_exp =
(* The expression construction (new <class>) only accepts a class
*identifier* (new <lid>), not a general class expression (new
<clexp>), and we need the latter in our rewrite rules.
This function uses a boilerplaty construction to turn an arbitrary
class expression into a class identifier:
new <cle>
is defined as
let module M = struct class cl = <cle> end in
new M.cl
*)
let open Ast_helper in
let noloc = Location.mknoloc in
let modname = "<class_exp_mod>" in
let clname = "<class_exp>" in
Exp.letmodule (noloc modname)
(Mod.structure [Str.class_ [Ci.mk (noloc clname) class_exp]])
(Exp.new_ (noloc (Longident.(Ldot (Lident modname, clname)))))
in
match class_expr.pcl_desc with
| Pcl_constr (lid, _type_args) ->
eval_as_exp (Pexp_new lid)
| Pcl_fun (arg, def, pat, cle) ->
eval_as_exp (Pexp_fun (arg, def, pat, new_ cle))
| Pcl_apply (cle, args) ->
eval_as_exp (Pexp_apply (new_ cle, args))
| Pcl_let (rec_flag, bindings, cle) ->
eval_as_exp (Pexp_let (rec_flag, bindings, new_ cle))
| Pcl_constraint (cle, cty) ->
eval_obj_new prims env cle
| Pcl_open (ov_flag, open_, cle) ->
eval_as_exp (Pexp_open (ov_flag, open_, new_ cle))
| Pcl_extension _ ->
unsupported class_expr.pcl_loc; assert false
| Pcl_structure class_structure ->
let obj = eval_class_structure prims env class_expr.pcl_loc class_structure in
ptr @@ Object obj
and eval_class_structure prims env loc class_structure =
let eval_obj_field ((rev_inits,
parents, parents_in_scope,
variables, variables_in_scope,
methods) as state) class_field =
let in_object expr = {
source = Current_object;
instance_variable_scope = variables_in_scope;
named_parents_scope = parents_in_scope;
expr;
} in
match class_field.pcf_desc with
| Pcf_val (lab, _mut_flag, Cfk_virtual _) ->
(* we chose to ignore virtual variables and methods in object values;
it would be possible to give a more precise description by storing
them as fields without a value *)
(rev_inits,
parents,
SSet.remove lab.txt parents_in_scope,
variables,
variables_in_scope,
methods)
| Pcf_val (lab, _mut_flag, Cfk_concrete (_ov_flag, expr)) ->
let v = eval_expr prims env expr in
(rev_inits,
parents,
SSet.remove lab.txt parents_in_scope,
SMap.add lab.txt (ref v) variables,
SSet.add lab.txt variables_in_scope,
methods)
| Pcf_method (_lab, _priv_flag, Cfk_virtual _) ->
state
| Pcf_method (lab, _priv_flag, Cfk_concrete (_ov_flag, expr)) ->
(rev_inits,
parents, parents_in_scope,
variables, variables_in_scope,
SMap.add lab.txt (in_object expr) methods)
| Pcf_initializer expr ->
(in_object expr :: rev_inits,
parents, parents_in_scope,
variables, variables_in_scope,
methods)
| Pcf_inherit (_ov_flag, class_expr, parent_name) ->
let in_parent parent expr_in_object =
match expr_in_object.source with
| Parent _ -> expr_in_object
| Current_object -> { expr_in_object with source = Parent parent } in
begin match Ptr.get @@ eval_class_expr prims env class_expr with
| Object parent ->
let rev_inits =
let parent_initializers =
List.map (in_parent parent) parent.initializers in
List.rev_append parent_initializers rev_inits in
let parents, parents_in_scope = match parent_name with
| None -> parents, parents_in_scope
| Some name ->
SMap.add name.txt parent parents,
SSet.add name.txt parents_in_scope in
let variables =
SMap.union (fun _k _old new_ -> Some new_)
variables
parent.variables
in
let set_of_keys dict =
SMap.to_seq dict
|> Seq.map fst
|> SSet.of_seq in
let variables_in_scope =
(* first add the parent variables *)
SSet.union variables_in_scope
(set_of_keys parent.variables) in
let variables_in_scope =
(* then remove the 'super' name if any *)
match parent_name with
| None -> variables_in_scope
| Some name ->
SSet.remove name.txt variables_in_scope in
let methods =
SMap.union (fun _k _old new_ -> Some new_)
methods
(SMap.map (in_parent parent) parent.methods)
in
(rev_inits,
parents, parents_in_scope,
variables, variables_in_scope,
methods)
| _ -> mismatch loc; assert false
end
| Pcf_constraint _ ->
state
| Pcf_attribute _ ->
state
| Pcf_extension _ ->
unsupported loc; assert false
in
let self = class_structure.pcstr_self in
let fields = class_structure.pcstr_fields in
let (rev_inits,
parents, _parents_in_scope,
variables, _variables_in_scope,
methods) =
List.fold_left eval_obj_field
([],
SMap.empty, SSet.empty,
SMap.empty, SSet.empty,
SMap.empty) fields in
{
env;
self;
named_parents = parents;
initializers = List.rev rev_inits;
variables;
methods;
parent_view = [];
}
and eval_obj_initializers prims env obj =
let eval_init expr =
Runtime_base.unwrap_unit (eval_expr_in_object prims obj expr) in
List.iter eval_init obj.initializers
and eval_obj_new prims env class_expr =
match Ptr.get @@ eval_class_expr prims env class_expr with
| Object obj ->
eval_obj_initializers prims env obj;
ptr @@ Object obj
| other ->
(* Class expressions may validly return non-Obj values,
which have nothing to initialize. For example,
(new (fun x -> foo x))
returns the value of
(fun x -> new (foo x))
as a closure, which does not initialize.
*)
ptr @@ other
and eval_module_expr prims env me =
match me.pmod_desc with
| Pmod_ident lident -> env_get_module env lident
@ -521,8 +797,16 @@ and eval_structitem prims env it =
| Pstr_modtype _ -> env
| Pstr_open { popen_lid = lident; _ } ->
env_extend false env (env_get_module_data env lident)
| Pstr_class _ -> unsupported it.pstr_loc; assert false
| Pstr_class_type _ -> unsupported it.pstr_loc; assert false
| Pstr_class class_decls ->
let forward_env = ref env in
let add_class class_decl env =
let name = class_decl.pci_name.txt in
let class_expr = class_decl.pci_expr in
env_set_class name (class_expr, forward_env) env in
let env = List.fold_right add_class class_decls env in
forward_env := env;
env
| Pstr_class_type _ -> env
| Pstr_include { pincl_mod = me; pincl_loc = loc; _ } ->
let m = eval_module_expr prims env me in
env_extend true env (get_module_data env loc m)

21
interp.ml
View File

@ -236,23 +236,27 @@ module Compiler_files = struct
let asmcomp = List.map (Filename.concat "asmcomp") [
"cmx_format.mli";
"clambda.ml";
"cmm.ml";
"export_info.ml";
"compilenv.ml";
"import_approx.ml";
"debug/reg_with_debug_info.ml";
"debug/reg_availability_set.ml";
"debug/available_regs.ml";
"x86_ast.mli";
"x86_proc.ml";
"x86_dsl.ml";
"x86_gas.ml";
(* backend-specific files *)
"arch.ml";
"cmm.ml";
"reg.ml";
"mach.ml";
"proc.ml";
"selectgen.ml";
"spacetime_profiling.ml";
"selection.ml";
"closure.ml";
@ -262,6 +266,19 @@ module Compiler_files = struct
"branch_relaxation.ml";
"emitaux.ml";
"emit.ml";
"comballoc.ml";
"CSEgen.ml";
"CSE.ml";
"liveness.ml";
"deadcode.ml";
"split.ml";
"spill.ml";
"interf.ml";
"coloring.ml";
"reloadgen.ml";
"reload.ml";
"schedgen.ml";
"scheduling.ml";
"asmgen.ml";
]

2
runtime_base.ml
View File

@ -36,7 +36,7 @@ let wrap_bool b = ptr @@
let wrap_unit () = unit
let unwrap_unit = onptr @@ function
| Constructor ("()", _, None) -> ()
| Constructor ("()", 0, None) -> ()
| _ -> assert false
let wrap_bytes s = ptr @@ String s

4
runtime_stdlib.ml
View File

@ -122,9 +122,11 @@ let rec seeded_hash_param meaningful total seed = onptr @@ function
| String s ->
Hashtbl.seeded_hash_param meaningful total seed (Bytes.to_string s)
| Constructor (c, _, _v) -> Hashtbl.seeded_hash_param meaningful total seed c
| Object _ -> 0
| Array _a -> 0
| Record _r -> 0
| Fexpr _ | Fun _ | Function _ | InChannel _ | OutChannel _ | Prim _ | Lz _
| Fexpr _ | Fun _ | Function _
| InChannel _ | OutChannel _ | Prim _ | Lz _
| ModVal _ | Fun_with_extra_args _ ->
assert false