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

fast and compact classes 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5977 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2003-11-25 09:20:45 +00:00
parent e32f8e9858
commit f2095623ff
32 changed files with 1181 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

608
bytecomp/translclass.ml
View File

@ -27,6 +27,7 @@ type error = Illegal_class_expr
exception Error of Location.t * error
let lfunction params body =
if params = [] then body else
match body with
Lfunction (Curried, params', body') ->
Lfunction (Curried, params @ params', body')
@ -43,13 +44,14 @@ let lapply func args =
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
let transl_label l = Lconst (Const_base (Const_string l))
let lfield v i = Lprim(Pfield i, [Lvar v])
let transl_label l = share (Const_base (Const_string l))
let rec transl_meth_list lst =
Lconst
(List.fold_right
(fun lab rem -> Const_block (0, [Const_base (Const_string lab); rem]))
lst (Const_pointer 0))
if lst = [] then Lconst (Const_pointer 0) else
share (Const_block
(0, List.map (fun lab -> Const_base (Const_string lab)) lst))
let set_inst_var obj id expr =
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
@ -65,15 +67,26 @@ let copy_inst_var obj id expr templ offset =
[Lvar id';
Lvar offset])])]))
let transl_val tbl create name id rem =
Llet(StrictOpt, id, Lapply (oo_prim (if create then "new_variable"
else "get_variable"),
[Lvar tbl; transl_label name]),
rem)
let transl_val tbl create name =
Lapply (oo_prim (if create then "new_variable" else "get_variable"),
[Lvar tbl; transl_label name])
let transl_vals tbl create vals rem =
let transl_vals tbl create sure vals rem =
if create && sure && List.length vals > 1 then
let (_,id0) = List.hd vals in
let call =
Lapply(oo_prim "new_variables",
[Lvar tbl; transl_meth_list (List.map fst vals)]) in
let i = ref (List.length vals) in
Llet(Strict, id0, call,
List.fold_right
(fun (name,id) rem ->
decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
(List.tl vals) rem)
else
List.fold_right
(fun (name, id) rem -> transl_val tbl create name id rem)
(fun (name, id) rem ->
Llet(StrictOpt, id, transl_val tbl create name, rem))
vals rem
let transl_super tbl meths inh_methods rem =
@ -93,22 +106,27 @@ let create_object cl obj init =
let (inh_init, obj_init) = init obj' in
if obj_init = lambda_unit then
(inh_init,
Lapply (oo_prim "create_object_and_run_initializers",
[Lvar obj; Lvar cl]))
Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
else begin
(inh_init,
Llet(Strict, obj',
Lapply (oo_prim "create_object_opt", [Lvar obj; Lvar cl]),
Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
Lsequence(obj_init,
Lapply (oo_prim "run_initializers_opt",
[Lvar obj; Lvar obj'; Lvar cl]))))
Lapply (oo_prim "run_initializers_opt",
[obj; Lvar obj'; Lvar cl]))))
end
let rec build_object_init cl_table obj params inh_init cl =
let rec build_object_init cl_table obj params inh_init obj_init cl =
match cl.cl_desc with
Tclass_ident path ->
let obj_init = Ident.create "obj_init" in
(obj_init::inh_init, Lapply(Lvar obj_init, [Lvar obj]))
let envs, inh_init = inh_init in
let env =
match envs with None -> []
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
in
((envs, (obj_init, path)::inh_init),
Lapply(Lvar obj_init, env @ [obj]))
| Tclass_structure str ->
create_object cl_table obj (fun obj ->
let (inh_init, obj_init) =
@ -117,7 +135,8 @@ let rec build_object_init cl_table obj params inh_init cl =
match field with
Cf_inher (cl, _, _) ->
let (inh_init, obj_init') =
build_object_init cl_table obj [] inh_init cl
build_object_init cl_table (Lvar obj) [] inh_init
(fun _ -> lambda_unit) cl
in
(inh_init, lsequence obj_init' obj_init)
| Cf_val (_, id, exp) ->
@ -133,7 +152,7 @@ let rec build_object_init cl_table obj params inh_init cl =
rem)
vals obj_init)))
str.cl_field
(inh_init, lambda_unit)
(inh_init, obj_init obj)
in
(inh_init,
List.fold_right
@ -142,7 +161,7 @@ let rec build_object_init cl_table obj params inh_init cl =
params obj_init))
| Tclass_fun (pat, vals, cl, partial) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init cl
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
in
(inh_init,
let build params rem =
@ -157,29 +176,32 @@ let rec build_object_init cl_table obj params inh_init cl =
end)
| Tclass_apply (cl, oexprs) ->
let (inh_init, obj_init) =
build_object_init cl_table obj params inh_init cl
build_object_init cl_table obj params inh_init obj_init cl
in
(inh_init, transl_apply obj_init oexprs)
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init cl
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
in
(inh_init, Translcore.transl_let rec_flag defs obj_init)
| Tclass_constraint (cl, vals, pub_meths, concr_meths) ->
build_object_init cl_table obj params inh_init cl
build_object_init cl_table obj params inh_init obj_init cl
let rec build_object_init_0 cl_table params cl =
let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
match cl.cl_desc with
Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, obj_init) =
build_object_init_0 cl_table (vals @ params) cl
in
(inh_init, Translcore.transl_let rec_flag defs obj_init)
build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
| _ ->
let obj = Ident.create "self" in
let (inh_init, obj_init) = build_object_init cl_table obj params [] cl in
let obj_init = lfunction [obj] obj_init in
(inh_init, obj_init)
let self = Ident.create "self" in
let env = Ident.create "env" in
let obj = if ids = [] then lambda_unit else Lvar self in
let envs = if top then None else Some env in
let ((_,inh_init), obj_init) =
build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
let obj_init =
if ids = [] then obj_init else lfunction [self] obj_init in
(inh_init, lfunction [env] (subst_env env obj_init))
let bind_method tbl public_methods lab id cl_init =
if List.mem lab public_methods then
@ -192,138 +214,504 @@ let bind_method tbl public_methods lab id cl_init =
let bind_methods tbl public_methods meths cl_init =
Meths.fold (bind_method tbl public_methods) meths cl_init
let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
let output_methods tbl vals methods lam =
let lam =
match methods with
[] -> lam
| [lab; code] ->
lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
| _ ->
lsequence (Lapply(oo_prim "set_methods",
[Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
lam
in
transl_vals tbl true true vals lam
let rec ignore_cstrs cl =
match cl.cl_desc with
Tclass_constraint (cl, _, _, _) -> ignore_cstrs cl
| Tclass_apply (cl, _) -> ignore_cstrs cl
| _ -> cl
let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
match cl.cl_desc with
Tclass_ident path ->
begin match inh_init with
obj_init::inh_init ->
(obj_init, path')::inh_init ->
let lpath = transl_path path in
(inh_init,
Llet (Strict, obj_init,
Lapply(Lprim(Pfield 1, [transl_path path]), [Lvar cla]),
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
cl_init))
| _ ->
assert false
end
| Tclass_structure str ->
let (inh_init, cl_init) =
let (inh_init, cl_init, methods, values) =
List.fold_right
(fun field (inh_init, cl_init) ->
(fun field (inh_init, cl_init, methods, values) ->
match field with
Cf_inher (cl, vals, meths) ->
build_class_init cla pub_meths false inh_init
(transl_vals cla false vals
(transl_super cla str.cl_meths meths cl_init))
cl
let cl_init = output_methods cla values methods cl_init in
let inh_init, cl_init =
build_class_init cla pub_meths false inh_init
(transl_vals cla false false vals
(transl_super cla str.cl_meths meths cl_init))
msubst top cl in
(inh_init, cl_init, [], [])
| Cf_val (name, id, exp) ->
(inh_init, transl_val cla true name id cl_init)
(inh_init, cl_init, methods, (name, id)::values)
| Cf_meth (name, exp) ->
let met_code = msubst true (transl_exp exp) in
let met_code =
if !Clflags.native_code then begin
if !Clflags.native_code && List.length met_code = 1 then
(* Force correct naming of method for profiles *)
let met = Ident.create ("method_" ^ name) in
Llet(Strict, met, transl_exp exp, Lvar met)
end else
transl_exp exp in
(inh_init,
Lsequence(Lapply (oo_prim "set_method",
[Lvar cla;
Lvar (Meths.find name str.cl_meths);
met_code]),
[Llet(Strict, met, List.hd met_code, Lvar met)]
else met_code
in
(inh_init, cl_init,
Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
values)
(*
Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
Lvar cla ::
Lvar (Meths.find name str.cl_meths) ::
met_code),
cl_init))
*)
| Cf_let (rec_flag, defs, vals) ->
let vals =
List.map (function (id, _) -> (Ident.name id, id)) vals
in
(inh_init, transl_vals cla true vals cl_init)
(inh_init, cl_init, methods, vals @ values)
| Cf_init exp ->
(inh_init,
Lsequence(Lapply (oo_prim "add_initializer",
[Lvar cla; transl_exp exp]),
cl_init)))
Lvar cla :: msubst false (transl_exp exp)),
cl_init),
methods, values))
str.cl_field
(inh_init, cl_init)
(inh_init, cl_init, [], [])
in
let cl_init = output_methods cla values methods cl_init in
(inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
| Tclass_fun (pat, vals, cl, _) ->
let (inh_init, cl_init) =
build_class_init cla pub_meths cstr inh_init cl_init cl
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
(inh_init, transl_vals cla true vals cl_init)
(inh_init, transl_vals cla true false vals cl_init)
| Tclass_apply (cl, exprs) ->
build_class_init cla pub_meths cstr inh_init cl_init cl
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, cl_init) =
build_class_init cla pub_meths cstr inh_init cl_init cl
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
(inh_init, transl_vals cla true vals cl_init)
(inh_init, transl_vals cla true false vals cl_init)
| Tclass_constraint (cl, vals, meths, concr_meths) ->
let core cl_init =
build_class_init cla pub_meths true inh_init cl_init cl
in
if cstr then
core cl_init
else
let virt_meths =
List.fold_right
(fun lab rem ->
if Concr.mem lab concr_meths then rem else lab::rem)
meths
[]
in
let (inh_init, cl_init) =
core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]),
cl_init))
in
(inh_init,
Lsequence(Lapply (oo_prim "narrow",
[Lvar cla;
transl_meth_list vals;
transl_meth_list virt_meths;
transl_meth_list (Concr.elements concr_meths)]),
cl_init))
let virt_meths =
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
let narrow_args =
[Lvar cla;
transl_meth_list vals;
transl_meth_list virt_meths;
transl_meth_list (Concr.elements concr_meths)] in
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tclass_ident path, (obj_init, path')::inh_init ->
assert (Path.same path path');
let lpath = transl_path path in
(inh_init,
Llet (Strict, obj_init,
Lapply(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
cl_init))
| _ ->
let core cl_init =
build_class_init cla pub_meths true inh_init cl_init msubst top cl
in
if cstr then core cl_init else
let (inh_init, cl_init) =
core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
in
(inh_init,
Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
end
let rec build_class_lets cl =
match cl.cl_desc with
Tclass_let (rec_flag, defs, vals, cl) ->
let env, wrap = build_class_lets cl in
(env, fun x -> Translcore.transl_let rec_flag defs (wrap x))
| _ ->
(cl.cl_env, fun x -> x)
(*
XXX Il devrait etre peu couteux d'ecrire des classes :
class c x y = d e f
*)
let rec transl_class_rebind obj_init cl =
match cl.cl_desc with
Tclass_ident path ->
(path, obj_init)
| Tclass_fun (pat, _, cl, partial) ->
let path, obj_init = transl_class_rebind obj_init cl in
let build params rem =
let param = name_pattern "param" [pat, ()] in
Lfunction (Curried, param::params,
Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem] partial)
in
(path,
match obj_init with
Lfunction (Curried, params, rem) -> build params rem
| rem -> build [] rem)
| Tclass_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl in
(path, transl_apply obj_init oexprs)
| Tclass_let (rec_flag, defs, vals, cl) ->
let path, obj_init = transl_class_rebind obj_init cl in
(path, Translcore.transl_let rec_flag defs obj_init)
| Tclass_structure {cl_field = [Cf_inher(cl, _, _)]} ->
let path, obj_init = transl_class_rebind obj_init cl in
(path, obj_init)
| Tclass_structure _ -> raise Exit
| Tclass_constraint (cl', _, _, _) ->
let path, obj_init = transl_class_rebind obj_init cl' in
let rec check_constraint = function
Tcty_constr(path', _, _) when Path.same path path' -> ()
| Tcty_fun (_, _, cty) -> check_constraint cty
| _ -> raise Exit
in
check_constraint cl.cl_type;
(path, obj_init)
let rec transl_class_rebind_0 self obj_init cl =
match cl.cl_desc with
Tclass_let (rec_flag, defs, vals, cl) ->
let path, obj_init = transl_class_rebind_0 self obj_init cl in
(path, Translcore.transl_let rec_flag defs obj_init)
| _ ->
let path, obj_init = transl_class_rebind obj_init cl in
(path, lfunction [self] obj_init)
let transl_class_rebind ids cl =
try
let obj_init = Ident.create "obj_init"
and self = Ident.create "self" in
let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
let id = (obj_init' = lfunction [self] obj_init0) in
if id then transl_path path else
let cla = Ident.create "class"
and new_init = Ident.create "new_init"
and arg = Ident.create "arg"
and env_init = Ident.create "env_init"
and table = Ident.create "table"
and envs = Ident.create "envs" in
Llet(
Strict, new_init, lfunction [obj_init] obj_init',
Llet(
Alias, cla, transl_path path,
Lprim(Pmakeblock(0, Immutable),
[Lapply(Lvar new_init, [lfield cla 0]);
lfunction [table]
(Llet(Strict, env_init,
Lapply(lfield cla 1, [Lvar table]),
lfunction [envs]
(Lapply(Lvar new_init,
[Lapply(Lvar env_init, [Lvar envs])]))));
lfield cla 2;
lfield cla 3])))
with Exit ->
lambda_unit
(* Rewrite a closure using builtins. Improves native code size. *)
let rec module_path = function
Lvar id ->
let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
| Lprim(Pfield _, [p]) -> module_path p
| Lprim(Pgetglobal _, []) -> true
| _ -> false
let const_path local = function
Lvar id -> not (List.mem id local)
| Lconst _ -> true
| Lfunction (Curried, _, body) ->
let fv = free_variables body in
List.for_all (fun x -> not (IdentSet.mem x fv)) local
| p -> module_path p
let rec builtin_meths self env env2 body =
let const_path = const_path (env::self) in
let conv = function
(* Lvar s when List.mem s self -> "_self", [] *)
| p when const_path p -> "const", [p]
| Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self ->
"var", [Lvar n]
| Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
"env", [Lvar env2; Lconst(Const_pointer n)]
| Lsend(Lvar n, Lvar s, []) when List.mem s self ->
"meth", [Lvar n]
| _ -> raise Not_found
in
match body with
| Llet(Alias, s', Lvar s, body) when List.mem s self ->
builtin_meths self env env2 body
| Lapply(f, [arg]) when const_path f ->
let s, args = conv arg in ("app_"^s, f :: args)
| Lapply(f, [arg; p]) when const_path f && const_path p ->
let s, args = conv arg in
("app_"^s^"_const", f :: args @ [p])
| Lapply(f, [p; arg]) when const_path f && const_path p ->
let s, args = conv arg in
("app_const_"^s, f :: p :: args)
| Lsend(Lvar n, Lvar s, [arg]) when List.mem s self ->
let s, args = conv arg in
("meth_app_"^s, Lvar n :: args)
| Lfunction (Curried, [x], body) ->
let rec enter self = function
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
when Ident.same x x' && List.mem s self ->
("set_var", [Lvar n])
| Llet(Alias, s', Lvar s, body) when List.mem s self ->
enter (s'::self) body
| _ -> raise Not_found
in enter self body
| Lfunction _ -> raise Not_found
| _ ->
let s, args = conv body in ("get_"^s, args)
module M = struct
open CamlinternalOO
let builtin_meths arr self env env2 body =
let builtin, args = builtin_meths self env env2 body in
if not arr then [Lapply(oo_prim builtin, args)] else
let tag = match builtin with
"get_const" -> GetConst
| "get_var" -> GetVar
| "get_env" -> GetEnv
| "get_meth" -> GetMeth
| "set_var" -> SetVar
| "app_const" -> AppConst
| "app_var" -> AppVar
| "app_env" -> AppEnv
| "app_meth" -> AppMeth
| "app_const_const" -> AppConstConst
| "app_const_var" -> AppConstVar
| "app_const_env" -> AppConstEnv
| "app_const_meth" -> AppConstMeth
| "app_var_const" -> AppVarConst
| "app_env_const" -> AppEnvConst
| "app_meth_const" -> AppMethConst
| "meth_app_const" -> MethAppConst
| "meth_app_var" -> MethAppVar
| "meth_app_env" -> MethAppEnv
| "meth_app_meth" -> MethAppMeth
| _ -> assert false
in Lconst(Const_pointer(Obj.magic tag)) :: args
end
open M
(*
XXX
Exploiter le fait que les methodes sont definies dans l'ordre pour
l'initialisation des classes (et les variables liees par un
let ???) ?
Traduction d'une classe.
Plusieurs cas:
* reapplication d'une classe connue -> transl_class_rebind
* classe sans dependances locales -> traduction directe
* avec dependances locale -> creation d'un arbre de stubs,
avec un noeud pour chaque classe locale heritee
Une classe est un 4-uplet:
(obj_init, class_init, env_init, env)
obj_init: fonction de creation d'objet (unit -> obj)
class_init: fonction d'heritage (table -> env_init)
(une seule par code source)
env_init: parametrage par l'environnement local (env -> params -> obj_init)
(une par combinaison d'env_init herites)
env: environnement local
Si ids=0 (objet immediat), alors on ne conserve que env_init.
*)
let transl_class ids cl_id arity pub_meths cl =
(* First check if it is not only a rebind *)
let rebind = transl_class_rebind ids cl in
if rebind <> lambda_unit then rebind else
(* Prepare for heavy environment handling *)
let tables = Ident.create (Ident.name cl_id ^ "_tables") in
let (top_env, req) = oo_add_class tables in
let top = not req in
let cl_env, llets = build_class_lets cl in
let new_ids = if top then [] else Env.diff top_env cl_env in
let env2 = Ident.create "env" in
let subst env lam i0 new_ids' =
let fv = free_variables lam in
let fv = List.fold_right IdentSet.remove !new_ids' fv in
let fv =
IdentSet.filter (fun id -> List.mem id new_ids) fv in
new_ids' := !new_ids' @ IdentSet.elements fv;
let i = ref (i0-1) in
List.fold_left
(fun subst id ->
incr i; Ident.add id (lfield env !i) subst)
Ident.empty !new_ids'
in
let new_ids_meths = ref [] in
let msubst arr = function
Lfunction (Curried, self :: args, body) ->
let env = Ident.create "env" in
let body' =
if new_ids = [] then body else
subst_lambda (subst env body 0 new_ids_meths) body in
begin try
(* Doesn't seem to improve size for bytecode *)
(* if not !Clflags.native_code then raise Not_found; *)
builtin_meths arr [self] env env2 (lfunction args body')
with Not_found ->
[lfunction (self :: args)
(if not (IdentSet.mem env (free_variables body')) then body' else
Llet(Alias, env,
Lprim(Parrayrefu Paddrarray,
[Lvar self; Lvar env2]), body'))]
end
| _ -> assert false
in
let new_ids_init = ref [] in
let env1 = Ident.create "env" in
let copy_env envs self =
if top then lambda_unit else
Lifused(env2, Lprim(Parraysetu Paddrarray,
[Lvar self; Lvar env2; lfield env1 0]))
and subst_env envs lam =
if top then lam else
Llet(Alias, env1, lfield envs 0,
subst_lambda (subst env1 lam 1 new_ids_init) lam)
in
(* Now we start compiling the class *)
let cla = Ident.create "class" in
let (inh_init, obj_init) = build_object_init_0 cla [] cl in
let (inh_init, obj_init) =
build_object_init_0 cla [] cl copy_env subst_env top ids in
if not (Translcore.check_recursive_lambda ids obj_init) then
raise(Error(cl.cl_loc, Illegal_class_expr));
let (inh_init, cl_init) =
build_class_init cla pub_meths true (List.rev inh_init) obj_init cl
let (inh_init', cl_init) =
build_class_init cla pub_meths true (List.rev inh_init)
obj_init msubst top cl
in
assert (inh_init = []);
let table = Ident.create "table" in
let class_init = Ident.create "class_init" in
let obj_init = Ident.create "obj_init" in
Llet(Strict, table,
Lapply (oo_prim "create_table", [transl_meth_list pub_meths]),
Llet(Strict, class_init,
Lfunction(Curried, [cla], cl_init),
Llet(Strict, obj_init, Lapply(Lvar class_init, [Lvar table]),
Lsequence(Lapply (oo_prim "init_class", [Lvar table]),
Lprim(Pmakeblock(0, Immutable),
[Lvar obj_init;
Lvar class_init;
Lvar table])))))
assert (inh_init' = []);
let table = Ident.create "table"
and class_init = Ident.create "class_init"
and env_init = Ident.create "env_init"
and obj_init = Ident.create "obj_init" in
let ltable table lam =
Llet(Strict, table,
Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
and ldirect obj_init =
Llet(Strict, obj_init, cl_init,
Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
Lapply(Lvar obj_init, [lambda_unit])))
in
(* Simplest case: an object defined at toplevel (ids=[]) *)
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
let class_stub =
Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit])
let lclass lam =
Llet(Strict, class_init, Lfunction(Curried, [cla], cl_init), lam)
and lbody =
Lapply (oo_prim "make_class",
[transl_meth_list pub_meths; Lvar class_init])
in
(* Still easy: a class defined at toplevel *)
if top then llets (lclass lbody) else
(* Now for the hard stuff: prepare for table cacheing *)
let env_index = Ident.create "env_index"
and envs = Ident.create "envs" in
let lenvs =
if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
then lambda_unit
else Lvar envs in
let lenv =
if !new_ids_meths = [] && !new_ids_init = [] then lambda_unit else
Lprim(Pmakeblock(0, Immutable),
(if !new_ids_meths = [] then lambda_unit else
Lprim(Pmakeblock(0, Immutable),
List.map (fun id -> Lvar id) !new_ids_meths)) ::
List.map (fun id -> Lvar id) !new_ids_init)
and linh_envs =
List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
(List.rev inh_init)
in
let make_envs lam =
Llet(StrictOpt, envs,
Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs),
lam)
and def_ids cla lam =
Llet(StrictOpt, env2,
Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
lam)
in
let obj_init2 = Ident.create "obj_init"
and cached = Ident.create "cached" in
let inh_paths =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
let inh_keys =
List.map (fun (_,p) -> Lprim(Pfield 2, [transl_path p])) inh_paths in
let lclass lam =
Llet(Strict, class_init,
Lfunction(Curried, [cla], def_ids cla cl_init), lam)
and lcache lam =
if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
Llet(Strict, cached,
Lapply(oo_prim "lookup_tables",
[Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
lam)
and lset cached i lam =
Lprim(Psetfield(i, true), [Lvar cached; lam])
in
let ldirect () =
ltable cla
(Llet(Strict, env_init, def_ids cla cl_init,
Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
lset cached 0 (Lvar env_init))))
in
llets (
lcache (
Lsequence(
Lifthenelse(lfield cached 0, lambda_unit,
if ids = [] then ldirect () else
lclass (
Lapply (oo_prim "make_class_store",
[transl_meth_list pub_meths;
Lvar class_init; Lvar cached]))),
make_envs (
if ids = [] then Lapply(lfield cached 0, [lenvs]) else
Lprim(Pmakeblock(0, Immutable),
[Lapply(lfield cached 0, [lenvs]);
lfield cached 1;
lfield cached 0;
lenvs])))))
(* Dummy for recursive modules *)
let dummy_class undef_fn =
Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"])
Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit])
(* Wrapper for class compilation *)
let transl_class ids cl_id arity pub_meths cl =
oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
let () =
transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
(* Error report *)

1
bytecomp/translclass.mli
View File

@ -15,7 +15,6 @@
open Typedtree
open Lambda
val class_stub : lambda
val dummy_class : lambda -> lambda
val transl_class :
Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;

72
bytecomp/translcore.ml
View File

@ -36,6 +36,10 @@ let transl_module =
ref((fun cc rootpath modl -> assert false) :
module_coercion -> Path.t option -> module_expr -> lambda)
let transl_object =
ref (fun id s cl -> assert false :
Ident.t -> string list -> class_expr -> lambda)
(* Translation of primitives *)
let comparisons_table = create_hashtable 11 [
@ -500,9 +504,23 @@ let assert_failed loc =
(* Translation of expressions *)
let rec transl_exp e =
let eval_once =
(* Whether classes for immediate objects must be cached *)
match e.exp_desc with
Texp_function _ | Texp_for _ | Texp_while _ -> false
| _ -> true
in
if eval_once then transl_exp0 e else
Translobj.oo_wrap e.exp_env true transl_exp0 e
and transl_exp0 e =
match e.exp_desc with
Texp_ident(path, {val_kind = Val_prim p}) ->
transl_primitive p
if p.prim_name = "%send" then
let obj = Ident.create "obj" and meth = Ident.create "meth" in
Lfunction(Curried, [obj; meth], Lsend(Lvar meth, Lvar obj, []))
else
transl_primitive p
| Texp_ident(path, {val_kind = Val_anc _}) ->
raise(Error(e.exp_loc, Free_super_var))
| Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
@ -524,7 +542,10 @@ let rec transl_exp e =
when List.length args = p.prim_arity
&& List.for_all (fun (arg,_) -> arg <> None) args ->
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
let prim = transl_prim p args in
if p.prim_name = "%send" then
let obj = transl_exp (List.hd args) in
event_after e (Lsend (transl_exp (List.nth args 1), obj, []))
else let prim = transl_prim p args in
begin match (prim, args) with
(Praise, [arg1]) ->
Lprim(Praise, [event_after arg1 (transl_exp arg1)])
@ -665,6 +686,13 @@ let rec transl_exp e =
| Texp_lazy e ->
let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
| Texp_object (cs, cty, meths) ->
let cl = Ident.create "class" in
!transl_object cl meths
{ cl_desc = Tclass_structure cs;
cl_loc = e.exp_loc;
cl_type = Tcty_signature cty;
cl_env = e.exp_env }
and transl_list expr_list =
List.map transl_exp expr_list
@ -735,33 +763,6 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
transl_function exp.exp_loc false repr partial' pl in
((Curried, param :: params),
Matching.for_function loc None (Lvar param) [pat, body] partial)
(*
| [({pat_desc = Tpat_var id} as pat),
({exp_desc = Texp_let(Nonrecursive, cases,
({exp_desc = Texp_function _} as e2))} as e1)]
when Ident.name id = "*opt*" ->
transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2]
| [pat, exp] when bindings <> [] ->
let exp =
List.fold_left
(fun exp cases ->
{exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
exp bindings
in
transl_function loc untuplify_fn repr [] partial [pat, exp]
| (pat, exp)::_ when bindings <> [] ->
let param = name_pattern "param" pat_expr_list in
let exp =
{ exp with exp_loc = loc; exp_desc =
Texp_match
({exp with exp_type = pat.pat_type; exp_desc =
Texp_ident (Path.Pident param,
{val_type = pat.pat_type; val_kind = Val_reg})},
pat_expr_list, partial) }
in
transl_function loc untuplify_fn repr bindings Total
[{pat with pat_desc = Tpat_var param}, exp]
*)
| ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
begin try
let size = List.length pl in
@ -877,6 +878,19 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
end
end
(* Wrapper for class compilation *)
(*
let transl_exp = transl_exp_wrap
let transl_let rec_flag pat_expr_list body =
match pat_expr_list with
[] -> body
| (_, expr) :: _ ->
Translobj.oo_wrap expr.exp_env false
(transl_let rec_flag pat_expr_list) body
*)
(* Compile an exception definition *)
let transl_exception id path decl =

2
bytecomp/translcore.mli
View File

@ -46,3 +46,5 @@ val report_error: formatter -> error -> unit
(* Forward declaration -- to be filled in by Translmod.transl_module *)
val transl_module :
(module_coercion -> Path.t option -> module_expr -> lambda) ref
val transl_object :
(Ident.t -> string list -> class_expr -> lambda) ref

27
bytecomp/translmod.ml
View File

@ -248,19 +248,22 @@ let rec transl_module cc rootpath mexp =
transl_structure [] cc rootpath str
| Tmod_functor(param, mty, body) ->
let bodypath = functor_path rootpath param in
begin match cc with
Tcoerce_none ->
Lfunction(Curried, [param], transl_module Tcoerce_none bodypath body)
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
Lfunction(Curried, [param'],
Llet(Alias, param, apply_coercion ccarg (Lvar param'),
transl_module ccres bodypath body))
| _ ->
fatal_error "Translmod.transl_module"
end
oo_wrap mexp.mod_env true
(function
| Tcoerce_none ->
Lfunction(Curried, [param],
transl_module Tcoerce_none bodypath body)
| Tcoerce_functor(ccarg, ccres) ->
let param' = Ident.create "funarg" in
Lfunction(Curried, [param'],
Llet(Alias, param, apply_coercion ccarg (Lvar param'),
transl_module ccres bodypath body))
| _ ->
fatal_error "Translmod.transl_module")
cc
| Tmod_apply(funct, arg, ccarg) ->
apply_coercion cc
oo_wrap mexp.mod_env true
(apply_coercion cc)
(Lapply(transl_module Tcoerce_none None funct,
[transl_module ccarg None arg]))
| Tmod_constraint(arg, mty, ccarg) ->

85
bytecomp/translobj.ml
View File

@ -26,6 +26,22 @@ let oo_prim name =
with Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
(* Share blocks *)
let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
let share c =
match c with
Const_block (n, l) when l <> [] ->
begin try
Lvar (Hashtbl.find consts c)
with Not_found ->
let id = Ident.create "shared" in
Hashtbl.add consts c id;
Lvar id
end
| _ -> Lconst c
(* Collect labels *)
let used_methods = ref ([] : (string * Ident.t) list);;
@ -39,6 +55,7 @@ let meth lab =
id
let reset_labels () =
Hashtbl.clear consts;
used_methods := []
(* Insert labels *)
@ -46,17 +63,61 @@ let reset_labels () =
let string s = Lconst (Const_base (Const_string s))
let transl_label_init expr =
if !used_methods = [] then
expr
else
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
consts expr
in
let expr =
if !used_methods = [] then expr else
let init = Ident.create "new_method" in
let expr' =
Llet(StrictOpt, init, oo_prim "new_method",
List.fold_right
(fun (lab, id) expr ->
Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
!used_methods
expr)
Llet(StrictOpt, init, oo_prim "new_method",
List.fold_right
(fun (lab, id) expr ->
Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
!used_methods
expr)
in
reset_labels ();
expr
(* Share classes *)
let wrapping = ref false
let required = ref true
let top_env = ref Env.empty
let classes = ref []
let oo_add_class id =
classes := id :: !classes;
(!top_env, !required)
let oo_wrap env req f x =
if !wrapping then
if !required then f x else
try required := true; let lam = f x in required := false; lam
with exn -> required := false; raise exn
else try
wrapping := true;
required := req;
top_env := env;
classes := [];
let lambda = f x in
let lambda =
List.fold_left
(fun lambda id ->
Llet(StrictOpt, id,
Lprim(Pmakeblock(0, Mutable),
[lambda_unit; lambda_unit; lambda_unit]),
lambda))
lambda !classes
in
reset_labels ();
expr'
wrapping := false;
top_env := Env.empty;
lambda
with exn ->
wrapping := false;
top_env := Env.empty;
raise exn

10
bytecomp/translobj.mli
View File

@ -12,9 +12,15 @@
(* $Id$ *)
val oo_prim: string -> Lambda.lambda
open Lambda
val oo_prim: string -> lambda
val share: structured_constant -> lambda
val meth: string -> Ident.t
val reset_labels: unit -> unit
val transl_label_init: Lambda.lambda -> Lambda.lambda
val transl_label_init: lambda -> lambda
val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
val oo_add_class: Ident.t -> Env.t * bool

36
otherlibs/labltk/browser/searchpos.ml
View File

@ -674,6 +674,23 @@ let rec search_pos_structure ~pos str =
| Tstr_include (m, _) -> search_pos_module_expr m ~pos
end
and search_pos_class_structure ~pos cls =
List.iter cls.cl_field ~f:
begin function
Cf_inher (cl, _, _) ->
search_pos_class_expr cl ~pos
| Cf_val (_, _, exp) -> search_pos_expr exp ~pos
| Cf_meth (_, exp) -> search_pos_expr exp ~pos
| Cf_let (_, pel, iel) ->
List.iter pel ~f:
begin fun (pat, exp) ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp ~pos
end;
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
| Cf_init exp -> search_pos_expr exp ~pos
end
and search_pos_class_expr ~pos cl =
if in_loc cl.cl_loc ~pos then begin
begin match cl.cl_desc with
@ -681,21 +698,7 @@ and search_pos_class_expr ~pos cl =
add_found_str (`Class (path, cl.cl_type))
~env:!start_env ~loc:cl.cl_loc
| Tclass_structure cls ->
List.iter cls.cl_field ~f:
begin function
Cf_inher (cl, _, _) ->
search_pos_class_expr cl ~pos
| Cf_val (_, _, exp) -> search_pos_expr exp ~pos
| Cf_meth (_, exp) -> search_pos_expr exp ~pos
| Cf_let (_, pel, iel) ->
List.iter pel ~f:
begin fun (pat, exp) ->
search_pos_pat pat ~pos ~env:exp.exp_env;
search_pos_expr exp ~pos
end;
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
| Cf_init exp -> search_pos_expr exp ~pos
end
search_pos_class_structure ~pos cls
| Tclass_fun (pat, iel, cl, _) ->
search_pos_pat pat ~pos ~env:pat.pat_env;
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
@ -802,6 +805,9 @@ and search_pos_expr ~pos exp =
search_pos_expr exp ~pos
| Texp_lazy exp ->
search_pos_expr exp ~pos
| Texp_object (cls, _, _) ->
search_pos_class_structure ~pos cls
end;
add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
end

7
stdlib/Makefile
View File

@ -31,8 +31,8 @@ BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
printf.cmo format.cmo scanf.cmo \
arg.cmo printexc.cmo gc.cmo \
digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
genlex.cmo callback.cmo weak.cmo \
digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
genlex.cmo weak.cmo \
lazy.cmo filename.cmo complex.cmo
LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
@ -119,6 +119,9 @@ pervasives.p.cmx: pervasives.ml
camlinternalOO.cmi: camlinternalOO.mli
$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
camlinternalOO.cmx: camlinternalOO.ml
$(CAMLOPT) $(OPTCOMPFLAGS) -inline 0 camlinternalOO.ml
# labelled modules require the -nolabels flag
labelled.cmo:
$(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) \

187
stdlib/camlinternalOO.ml
View File

@ -327,7 +327,13 @@ let get_method table label =
let (buck, elem) = decode label in
table.buckets.(buck).(elem)
let to_list arr =
if arr == magic 0 then [] else Array.to_list arr
let narrow table vars virt_meths concr_meths =
let vars = to_list vars
and virt_meths = to_list virt_meths
and concr_meths = to_list concr_meths in
let virt_meth_labs = List.map (get_method_label table) virt_meths in
let concr_meth_labs = List.map (get_method_label table) concr_meths in
table.previous_states <-
@ -387,6 +393,13 @@ let new_variable table name =
table.vars <- Vars.add name index table.vars;
index
let new_variables table names =
let index = new_variable table names.(0) in
for i = 1 to Array.length names - 1 do
ignore (new_variable table names.(i))
done;
index
let get_variable table name =
Vars.find name table.vars
@ -395,12 +408,13 @@ let add_initializer table f =
let create_table public_methods =
let table = new_table () in
List.iter
(function met ->
let lab = new_method met in
table.methods_by_name <- Meths.add met lab table.methods_by_name;
table.methods_by_label <- Labs.add lab true table.methods_by_label)
public_methods;
if public_methods != magic 0 then
Array.iter
(function met ->
let lab = new_method met in
table.methods_by_name <- Meths.add met lab table.methods_by_name;
table.methods_by_label <- Labs.add lab true table.methods_by_label)
public_methods;
table
let init_class table =
@ -409,6 +423,28 @@ let init_class table =
compact_buckets table.buckets;
table.initializers <- List.rev table.initializers
let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
narrow cla vals virt_meths concr_meths;
let init =
if top then super cla env else Obj.repr (super cla) in
widen cla;
init
let make_class pub_meths class_init =
let table = create_table pub_meths in
let env_init = class_init table in
init_class table;
(env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
type init_table = { mutable env_init: t; mutable class_init: table -> t }
let make_class_store pub_meths class_init init_table =
let table = create_table pub_meths in
let env_init = class_init table in
init_class table;
init_table.class_init <- class_init;
init_table.env_init <- env_init
(**** Objects ****)
let create_object table =
@ -453,9 +489,148 @@ let create_object_and_run_initializers obj_0 table =
obj
end
(* Equivalent primitive below
let send obj lab =
let (buck, elem) = decode lab in
(magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
*)
external send : obj -> label -> 'a = "%send"
(**** table collection access ****)
type tables = Empty | Cons of table * tables * tables
type mut_tables =
{key: table; mutable data: tables; mutable next: tables}
external mut : tables -> mut_tables = "%identity"
let build_path n keys tables =
let res = Cons (Obj.magic 0, Empty, Empty) in
let r = ref res in
for i = 0 to n do
r := Cons (keys.(i), !r, Empty)
done;
tables.data <- !r;
res
let rec lookup_keys i keys tables =
if i < 0 then tables else
let key = keys.(i) in
let rec lookup_key tables =
if tables.key == key then lookup_keys (i-1) keys tables.data else
if tables.next <> Empty then lookup_key (mut tables.next) else
let next = Cons (key, Empty, Empty) in
tables.next <- next;
build_path (i-1) keys (mut next)
in
lookup_key (mut tables)
let lookup_tables root keys =
let root = mut root in
if root.data <> Empty then
lookup_keys (Array.length keys - 1) keys root.data
else
build_path (Array.length keys - 1) keys root
(**** builtin methods ****)
type closure = item
external ret : (obj -> 'a) -> closure = "%identity"
let get_const x = ret (fun obj -> x)
let get_var n = ret (fun obj -> Array.unsafe_get obj n)
let get_env e n = ret (fun obj -> Obj.field (Array.unsafe_get obj e) n)
let get_meth n = ret (fun obj -> send obj n)
let set_var n = ret (fun obj x -> Array.unsafe_set obj n x)
let app_const f x = ret (fun obj -> f x)
let app_var f n = ret (fun obj -> f (Array.unsafe_get obj n))
let app_env f e n = ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n))
let app_meth f n = ret (fun obj -> f (send obj n))
let app_const_const f x y = ret (fun obj -> f x y)
let app_const_var f x n = ret (fun obj -> f x (Array.unsafe_get obj n))
let app_const_meth f x n = ret (fun obj -> f x (send obj n))
let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
let app_meth_const f n x = ret (fun obj -> f (send obj n) x)
let app_const_env f x e n =
ret (fun obj -> f x (Obj.field (Array.unsafe_get obj e) n))
let app_env_const f e n x =
ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n) x)
let meth_app_const n x = ret (fun obj -> (send obj n) x)
let meth_app_var n m =
ret (fun obj -> (send obj n) (Array.unsafe_get obj m))
let meth_app_env n e m =
ret (fun obj -> (send obj n) (Obj.field (Array.unsafe_get obj e) m))
let meth_app_meth n m =
ret (fun obj -> (send obj n) (send obj m))
type impl =
GetConst
| GetVar
| GetEnv
| GetMeth
| SetVar
| AppConst
| AppVar
| AppEnv
| AppMeth
| AppConstConst
| AppConstVar
| AppConstEnv
| AppConstMeth
| AppVarConst
| AppEnvConst
| AppMethConst
| MethAppConst
| MethAppVar
| MethAppEnv
| MethAppMeth
| Closure of Obj.t
let method_impl i arr =
let next () = incr i; magic arr.(!i) in
match next() with
GetConst -> let x : t = next() in ret (fun obj -> x)
| GetVar -> let n = next() in get_var n
| GetEnv -> let e = next() and n = next() in get_env e n
| GetMeth -> let n = next() in get_meth n
| SetVar -> let n = next() in set_var n
| AppConst -> let f = next() and x = next() in ret (fun obj -> f x)
| AppVar -> let f = next() and n = next () in app_var f n
| AppEnv ->
let f = next() and e = next() and n = next() in app_env f e n
| AppMeth -> let f = next() and n = next () in app_meth f n
| AppConstConst ->
let f = next() and x = next() and y = next() in ret (fun obj -> f x y)
| AppConstVar ->
let f = next() and x = next() and n = next() in app_const_var f x n
| AppConstEnv ->
let f = next() and x = next() and e = next () and n = next() in
app_const_env f x e n
| AppConstMeth ->
let f = next() and x = next() and n = next() in app_const_meth f x n
| AppVarConst ->
let f = next() and n = next() and x = next() in app_var_const f n x
| AppEnvConst ->
let f = next() and e = next () and n = next() and x = next() in
app_env_const f e n x
| AppMethConst ->
let f = next() and n = next() and x = next() in app_meth_const f n x
| MethAppConst ->
let n = next() and x = next() in meth_app_const n x
| MethAppVar ->
let n = next() and m = next() in meth_app_var n m
| MethAppEnv ->
let n = next() and e = next() and m = next() in meth_app_env n e m
| MethAppMeth ->
let n = next() and m = next() in meth_app_meth n m
| Closure _ as clo -> magic clo
let set_methods table methods =
let len = Array.length methods and i = ref 0 in
while !i < len do
let label = methods.(!i) and clo = method_impl i methods in
set_method table label clo;
incr i
done
(**** Statistics ****)

70
stdlib/camlinternalOO.mli
View File

@ -30,16 +30,27 @@ type meth
type t
type obj
val new_variable : table -> string -> int
val new_variables : table -> string array -> int
val get_variable : table -> string -> int
val get_method_label : table -> string -> label
val get_method : table -> label -> meth
val set_method : table -> label -> meth -> unit
val narrow : table -> string list -> string list -> string list -> unit
val set_methods : table -> label array -> unit
val narrow : table -> string array -> string array -> string array -> unit
val widen : table -> unit
val add_initializer : table -> (obj -> unit) -> unit
val dummy_table : table
val create_table : string list -> table
val create_table : string array -> table
val init_class : table -> unit
val inherits :
table -> string array -> string array -> string array ->
(t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
val make_class :
string array -> (table -> Obj.t -> t) ->
(t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
type init_table
val make_class_store :
string array -> (table -> t) -> init_table -> unit
(** {6 Objects} *)
@ -49,7 +60,60 @@ val create_object_opt : obj -> table -> obj
val run_initializers : obj -> table -> unit
val run_initializers_opt : obj -> obj -> table -> obj
val create_object_and_run_initializers : obj -> table -> obj
val send : obj -> label -> t
external send : obj -> label -> t = "%send"
(** {6 Table cache} *)
type tables
val lookup_tables : tables -> table array -> tables
(** {6 Builtins to reduce code size} *)
open Obj
type closure
val get_const : t -> closure
val get_var : int -> closure
val get_env : int -> int -> closure
val get_meth : label -> closure
val set_var : int -> closure
val app_const : (t -> t) -> t -> closure
val app_var : (t -> t) -> int -> closure
val app_env : (t -> t) -> int -> int -> closure
val app_meth : (t -> t) -> label -> closure
val app_const_const : (t -> t -> t) -> t -> t -> closure
val app_const_var : (t -> t -> t) -> t -> int -> closure
val app_const_env : (t -> t -> t) -> t -> int -> int -> closure
val app_const_meth : (t -> t -> t) -> t -> label -> closure
val app_var_const : (t -> t -> t) -> int -> t -> closure
val app_env_const : (t -> t -> t) -> int -> int -> t -> closure
val app_meth_const : (t -> t -> t) -> label -> t -> closure
val meth_app_const : label -> t -> closure
val meth_app_var : label -> int -> closure
val meth_app_env : label -> int -> int -> closure
val meth_app_meth : label -> label -> closure
type impl =
GetConst
| GetVar
| GetEnv
| GetMeth
| SetVar
| AppConst
| AppVar
| AppEnv
| AppMeth
| AppConstConst
| AppConstVar
| AppConstEnv
| AppConstMeth
| AppVarConst
| AppEnvConst
| AppMethConst
| MethAppConst
| MethAppVar
| MethAppEnv
| MethAppMeth
| Closure of t
(** {6 Parameters} *)

2
stdlib/sys.ml
View File

@ -78,4 +78,4 @@ let catch_break on =
(* OCaml version string, must be in the format described in sys.mli. *)
let ocaml_version = "3.07+5 (2003-11-19)";;
let ocaml_version = "3.07+6 (2003-11-25)";;

2
tools/addlabels.ml
View File

@ -276,7 +276,7 @@ let rec add_labels_expr ~text ~values ~classes expr =
| Pexp_override lst ->
List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
| Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
| Pexp_new _ | Pexp_assertfalse ->
| Pexp_new _ | Pexp_assertfalse | Pexp_object _ ->
()
let rec add_labels_class ~text ~classes ~values ~methods cl =

3
tools/depend.ml
View File

@ -154,7 +154,8 @@ let rec add_expr bv exp =
| Pexp_assertfalse -> ()
| Pexp_lazy (e) -> add_expr bv e
| Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
| Pexp_object (pat, fieldl) ->
add_pattern bv pat; List.iter (add_class_field bv) fieldl
and add_pat_expr_list bv pel =
List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel

3
tools/ocamlprof.ml
View File

@ -282,6 +282,9 @@ and rw_exp iflag sexp =
| Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
| Pexp_object (_, fieldl) ->
List.iter (rewrite_class_field iflag) fieldl
and rewrite_ifbody iflag ghost sifbody =
if !instr_if && not ghost then
insert_profile rw_exp sifbody

55
typing/ctype.ml
View File

@ -177,6 +177,8 @@ module TypePairs =
(**** Object field manipulation. ****)
let dummy_method = "*dummy method*"
let object_fields ty =
match (repr ty).desc with
Tobject (fields, _) -> fields
@ -452,7 +454,7 @@ let closed_class params sign =
List.iter mark_type params;
mark_type rest;
List.iter
(fun (lab, _, ty) -> if lab = "*dummy method*" then mark_type ty)
(fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
fields;
try
mark_type_node (repr sign.cty_self);
@ -603,13 +605,8 @@ let rec update_level env level ty =
end;
set_level ty level;
iter_type_expr (update_level env level) ty
| Tfield(_, k, _, _) ->
begin match field_kind_repr k with
Fvar _ (* {contents = None} *) -> raise (Unify [(ty, newvar2 level)])
| _ -> ()
end;
set_level ty level;
iter_type_expr (update_level env level) ty
| Tfield(lab, _, _, _) when lab = dummy_method ->
raise (Unify [(ty, newvar2 level)])
| _ ->
set_level ty level;
(* XXX what about abbreviations in Tconstr ? *)
@ -1448,7 +1445,7 @@ and unify3 env t1 t1' t2 t2' =
(* XXX One should do some kind of unification... *)
begin match (repr t2').desc with
Tobject (_, {contents = Some (_, va::_)})
when let va = repr va in va.desc = Tvar || va.desc = Tunivar ->
when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
()
| Tobject (_, nm2) ->
set_name nm2 !nm1
@ -1459,6 +1456,11 @@ and unify3 env t1 t1' t2 t2' =
unify_row env row1 row2
| (Tfield _, Tfield _) -> (* Actually unused *)
unify_fields env t1' t2'
| (Tfield(_,kind,_,rem), Tnil) | (Tnil, Tfield(_,kind,_,rem)) ->
begin match field_kind_repr kind with
Fvar r -> r := Some Fabsent
| _ -> raise (Unify [])
end
| (Tnil, Tnil) ->
()
| (Tpoly (t1, []), Tpoly (t2, [])) ->
@ -2569,6 +2571,24 @@ let rec filter_visited = function
let memq_warn t visited =
if List.memq t visited then (warn := true; true) else false
let rec lid_of_path sharp = function
Path.Pident id ->
Longident.Lident (sharp ^ Ident.name id)
| Path.Pdot (p1, s, _) ->
Longident.Ldot (lid_of_path "" p1, sharp ^ s)
| Path.Papply (p1, p2) ->
Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
let find_cltype_for_path env p =
let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
match cl_abbr.type_manifest with
Some ty ->
begin match (repr ty).desc with
Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
| _ -> raise Not_found
end
| None -> assert false
let rec build_subtype env visited loops posi level t =
let t = repr t in
match t.desc with
@ -2604,22 +2624,7 @@ let rec build_subtype env visited loops posi level t =
let level' = pred_expand level in
begin try match t'.desc with
Tobject _ when posi && not (opened_object t') ->
let rec lid_of_path sharp = function
Path.Pident id ->
Longident.Lident (sharp ^ Ident.name id)
| Path.Pdot (p1, s, _) ->
Longident.Ldot (lid_of_path "" p1, sharp ^ s)
| Path.Papply (p1, p2) ->
Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
in
let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
let body =
match cl_abbr.type_manifest with Some ty ->
begin match (repr ty).desc with
Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> ty
| _ -> raise Not_found
end
| None -> assert false in
let cl_abbr, body = find_cltype_for_path env p in
let ty =
subst env !current_level abbrev None cl_abbr.type_params tl body in
let ty = repr ty in

4
typing/ctype.mli
View File

@ -53,6 +53,7 @@ val none: type_expr
val repr: type_expr -> type_expr
(* Return the canonical representative of a type. *)
val dummy_method: label
val object_fields: type_expr -> type_expr
val flatten_fields:
type_expr -> (string * field_kind * type_expr) list * type_expr
@ -72,6 +73,7 @@ val set_object_name:
Ident.t -> type_expr -> type_expr list -> type_expr -> unit
val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
val sort_row_fields: (label * row_field) list -> (label * row_field) list
val merge_row_fields:
@ -189,7 +191,7 @@ val match_class_declarations:
val enlarge_type: Env.t -> type_expr -> type_expr * bool
(* Make a type larger, flag is true if some pruning had to be done *)
val subtype : Env.t -> type_expr -> type_expr -> unit -> unit
val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
(* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
It accumulates the constraints the type variables must
enforce and returns a function that inforce this

14
typing/env.ml
View File

@ -88,6 +88,20 @@ let empty = {
cltypes = Ident.empty;
summary = Env_empty }
let diff_keys tbl1 tbl2 =
let keys2 = Ident.keys tbl2 in
List.filter
(fun id ->
match Ident.find_same id tbl2 with Pident _, _ ->
(try ignore (Ident.find_same id tbl1); false with Not_found -> true)
| _ -> false)
keys2
let diff env1 env2 =
diff_keys env1.values env2.values @
diff_keys env1.modules env2.modules @
diff_keys env1.classes env2.classes
(* Forward declarations *)
let components_of_module' =

1
typing/env.mli
View File

@ -20,6 +20,7 @@ type t
val empty: t
val initial: t
val diff: t -> t -> Ident.t list
(* Lookup by paths *)

11
typing/ident.ml
View File

@ -159,3 +159,14 @@ let rec find_name name = function
k.data
else
find_name name (if c < 0 then l else r)
let rec keys_aux stack accu = function
Empty ->
begin match stack with
[] -> accu
| a :: l -> keys_aux l accu a
end
| Node(l, k, r, _) ->
keys_aux (l :: stack) (k.ident :: accu) r
let keys tbl = keys_aux [] [] tbl

1
typing/ident.mli
View File

@ -54,3 +54,4 @@ val empty: 'a tbl
val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> 'a
val keys: 'a tbl -> t list

10
typing/printtyp.ml
View File

@ -615,7 +615,7 @@ let class_var sch ppf l (m, t) =
"@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
let metho sch concrete ppf (lab, kind, ty) =
if lab <> "*dummy method*" then begin
if lab <> dummy_method then begin
let priv =
match field_kind_repr kind with
| Fvar _ (* {contents = None} *) -> "private "
@ -632,7 +632,7 @@ let method_type ty =
| _ -> ty
let tree_of_metho sch concrete csil (lab, kind, ty) =
if lab <> "*dummy method*" then begin
if lab <> dummy_method then begin
let priv =
match field_kind_repr kind with
| Fvar _ (* {contents = None} *) -> true
@ -765,7 +765,7 @@ let tree_of_cltype_declaration id cl =
Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
List.exists
(fun (lab, _, ty) ->
not (lab = "*dummy method*" || Concr.mem lab sign.cty_concr))
not (lab = dummy_method || Concr.mem lab sign.cty_concr))
fields in
Osig_class_type
@ -918,8 +918,8 @@ let explanation unif t3 t4 ppf =
| Tvar, Tunivar | Tunivar, Tvar ->
fprintf ppf "@,The universal variable %a would escape its scope"
type_expr (if t3.desc = Tunivar then t3 else t4)
| Tfield ("*dummy method*", _, _, _), _
| _, Tfield ("*dummy method*", _, _, _) ->
| Tfield (lab, _, _, _), _
| _, Tfield (lab, _, _, _) when lab = dummy_method ->
fprintf ppf
"@,Self type cannot be unified with a closed object type"
| Tfield (l, _, _, _), _ ->

189
typing/typeclass.ml
View File

@ -48,6 +48,7 @@ type error =
| Cannot_coerce_self of type_expr
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * (type_expr * type_expr) list
| Final_self_clash of (type_expr * type_expr) list
exception Error of Location.t * error
@ -61,7 +62,7 @@ exception Error of Location.t * error
Self type have a dummy private method, thus preventing it to become
closed.
*)
let dummy_method = "*dummy method*"
let dummy_method = Ctype.dummy_method
(*
Path associated to the temporary class type of a class being typed
@ -95,8 +96,7 @@ let rec generalize_class_type =
generalize_class_type cty
(* Return the virtual methods of a class type *)
let virtual_methods cty =
let sign = Ctype.signature_of_class_type cty in
let virtual_methods sign =
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
List.fold_left
(fun virt (lab, _, _) ->
@ -469,6 +469,7 @@ let rec class_field cl_num self_type meths vars
raise(Error(loc, Method_type_mismatch (lab, trace)))
end;
let meth_expr = make_method cl_num expr in
(* backup variables for Pexp_override *)
let vars_local = !vars in
let field =
@ -535,28 +536,45 @@ let rec class_field cl_num self_type meths vars
(val_env, met_env, par_env, field::fields,
concr_meths, warn_meths, inh_vals)
and class_structure cl_num val_env met_env (spat, str) =
and class_structure cl_num final val_env met_env loc (spat, str) =
(* Environment for substructures *)
let par_env = met_env in
(* Private self type more method access, with a dummy method preventing
it from being closed/escaped. *)
let self_type = Ctype.newvar () in
Ctype.unify val_env
(Ctype.filter_method val_env dummy_method Private self_type)
(Ctype.newty (Ttuple []));
(* Self binder *)
let (pat, meths, vars, val_env, meth_env, par_env) =
type_self_pattern cl_num val_env met_env par_env spat
type_self_pattern cl_num self_type val_env met_env par_env spat
in
let self_type = pat.pat_type in
let public_self = pat.pat_type in
(* Check that the binder has a correct type, and introduce a dummy
method preventing self type from being closed. *)
let ty = Ctype.newvar () in
Ctype.unify val_env
(Ctype.filter_method val_env dummy_method Private ty)
(Ctype.newty (Ttuple []));
begin try Ctype.unify val_env self_type ty with
(* Check that the binder has a correct type *)
let ty =
if final then Ctype.newty (Tobject (Ctype.newvar(), ref None))
else self_type in
begin try Ctype.unify val_env public_self ty with
Ctype.Unify _ ->
raise(Error(spat.ppat_loc, Pattern_type_clash self_type))
raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
end;
let get_methods ty =
(fst (Ctype.flatten_fields
(Ctype.object_fields (Ctype.expand_head val_env ty)))) in
if final then begin
(* Copy known information to still empty self_type *)
List.iter
(fun (lab,kind,ty) ->
try Ctype.unify val_env ty
(Ctype.filter_method val_env lab Public self_type)
with _ -> assert false)
(get_methods public_self)
end;
(* Class fields *)
(* Typing of class fields *)
let (_, _, _, fields, concr_meths, _, _) =
List.fold_left (class_field cl_num self_type meths vars)
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
@ -564,22 +582,56 @@ and class_structure cl_num val_env met_env (spat, str) =
str
in
Ctype.unify val_env self_type (Ctype.newvar ());
let methods =
if !Clflags.principal then
fst (Ctype.flatten_fields (Ctype.object_fields self_type))
else [] in
List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
let vars_final = !vars in
let sign =
{cty_self = public_self;
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
cty_concr = concr_meths } in
let methods = get_methods self_type in
let priv_meths =
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
methods in
if final then begin
(* Unify public_self and a copy of self_type. self_type will not
be modified after this point *)
Ctype.close_object self_type;
let mets = virtual_methods {sign with cty_self = self_type} in
if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
if lab = dummy_method then rem else
Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
methods (Ctype.newty Tnil) in
begin try Ctype.unify val_env public_self
(Ctype.newty (Tobject(self_methods, ref None)))
with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
end;
end;
(* Typing of method bodies *)
if !Clflags.principal then
List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
let fields = List.map Lazy.force (List.rev fields) in
vars := vars_final;
List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) methods;
if !Clflags.principal then
List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))
methods;
let meths = Meths.map (function (id, ty) -> id) !meths in
{cl_field = fields;
cl_meths = Meths.map (function (id, ty) -> id) !meths},
(* Check for private methods made public *)
let pub_meths' =
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
(get_methods public_self) in
let names = List.map (fun (x,_,_) -> x) in
let l1 = names priv_meths and l2 = names pub_meths' in
let added = List.filter (fun x -> List.mem x l1) l2 in
if added <> [] then
Location.prerr_warning loc
(Warnings.Other
(String.concat " "
("the following private methods were made public implicitly:\n "
:: added)));
{cty_self = self_type;
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
cty_concr = concr_meths }
{cl_field = fields; cl_meths = meths}, sign
and class_expr cl_num val_env met_env scl =
match scl.pcl_desc with
@ -610,17 +662,21 @@ and class_expr cl_num val_env met_env scl =
let cl =
rc {cl_desc = Tclass_ident path;
cl_loc = scl.pcl_loc;
cl_type = clty'}
cl_type = clty';
cl_env = val_env}
in
let (vals, meths, concrs) = extract_constraints clty in
rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = clty'}
cl_type = clty';
cl_env = val_env}
| Pcl_structure cl_str ->
let (desc, ty) = class_structure cl_num val_env met_env cl_str in
let (desc, ty) =
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
rc {cl_desc = Tclass_structure desc;
cl_loc = scl.pcl_loc;
cl_type = Tcty_signature ty}
cl_type = Tcty_signature ty;
cl_env = val_env}
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
let scases =
@ -682,7 +738,8 @@ and class_expr cl_num val_env met_env scl =
(Warnings.Other "This optional argument cannot be erased");
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type)}
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
cl_env = val_env}
| Pcl_apply (scl', sargs) ->
let cl = class_expr cl_num val_env met_env scl' in
let rec nonopt_labels ls ty_fun =
@ -769,7 +826,8 @@ and class_expr cl_num val_env met_env scl =
in
rc {cl_desc = Tclass_apply (cl, args);
cl_loc = scl.pcl_loc;
cl_type = cty}
cl_type = cty;
cl_env = val_env}
| Pcl_let (rec_flag, sdefs, scl') ->
let (defs, val_env) =
try
@ -802,7 +860,8 @@ and class_expr cl_num val_env met_env scl =
let cl = class_expr cl_num val_env met_env scl' in
rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
cl_loc = scl.pcl_loc;
cl_type = cl.cl_type}
cl_type = cl.cl_type;
cl_env = val_env}
| Pcl_constraint (scl', scty) ->
Ctype.begin_class_def ();
let context = Typetexp.narrow () in
@ -824,7 +883,8 @@ and class_expr cl_num val_env met_env scl =
let (vals, meths, concrs) = extract_constraints clty in
rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
cl_loc = scl.pcl_loc;
cl_type = snd (Ctype.instance_class [] clty)}
cl_type = snd (Ctype.instance_class [] clty);
cl_env = val_env}
(*******************************)
@ -1034,7 +1094,7 @@ let class_infos define_class kind
in
if cl.pci_virt = Concrete then begin
match virtual_methods typ with
match virtual_methods (Ctype.signature_of_class_type typ) with
[] -> ()
| mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
end;
@ -1149,10 +1209,13 @@ let merge_type_decls
let final_env define_class env
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr) =
Env.add_type obj_id obj_abbr (
Env.add_type cl_id cl_abbr (
Env.add_cltype ty_id cltydef (
if define_class then Env.add_class id clty env else env)))
(* Add definitions after cleaning them *)
Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) (
Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) (
Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
if define_class then
Env.add_class id (Subst.class_declaration Subst.identity clty) env
else env)))
(* Check that #c is coercible to c if there is a self-coercion *)
let check_coercions env
@ -1237,6 +1300,40 @@ let class_type_declarations env cls =
decl,
env)
let rec unify_parents env ty cl =
match cl.cl_desc with
Tclass_ident p ->
begin try
let decl = Env.find_class p env in
let _, body = Ctype.find_cltype_for_path env decl.cty_path in
Ctype.unify env ty (Ctype.instance body)
with exn -> assert (exn = Not_found)
end
| Tclass_structure st -> unify_parents_struct env ty st
| Tclass_fun (_, _, cl, _)
| Tclass_apply (cl, _)
| Tclass_let (_, _, _, cl)
| Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl
and unify_parents_struct env ty st =
List.iter
(function Cf_inher (cl, _, _) -> unify_parents env ty cl
| _ -> ())
st.cl_field
let type_object env loc s =
incr class_num;
let (desc, sign) =
class_structure (string_of_int !class_num) true env env loc s in
let sty = Ctype.expand_head env sign.cty_self in
Ctype.hide_private_methods sty;
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
let meths = List.map (fun (s,_,_) -> s) fields in
unify_parents_struct env sign.cty_self desc;
(desc, sign, meths)
let () =
Typecore.type_object := type_object
(*******************************)
(* Approximate the class declaration as class ['params] id = object end *)
@ -1318,9 +1415,9 @@ let report_error ppf = function
| Virtual_class (cl, mets) ->
let print_mets ppf mets =
List.iter (function met -> fprintf ppf "@ %s" met) mets in
let cl_mark = if cl then " type" else "" in
let cl_mark = if cl then "" else " type" in
fprintf ppf
"@[This class %s should be virtual@ \
"@[This class%s should be virtual@ \
@[<2>The following methods are undefined :%a@]
@]"
cl_mark print_mets mets
@ -1390,3 +1487,9 @@ let report_error ppf = function
Printtyp.report_unification_error ppf trace
(fun ppf -> fprintf ppf "Type")
(fun ppf -> fprintf ppf "is not compatible with type")
| Final_self_clash trace ->
Printtyp.report_unification_error ppf trace
(function ppf ->
fprintf ppf "This object is expected to have type")
(function ppf ->
fprintf ppf "but has actually type")

1
typing/typeclass.mli
View File

@ -71,6 +71,7 @@ type error =
| Cannot_coerce_self of type_expr
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * (type_expr * type_expr) list
| Final_self_clash of (type_expr * type_expr) list
exception Error of Location.t * error

45
typing/typecore.ml
View File

@ -67,6 +67,11 @@ let type_module =
ref ((fun env md -> assert false) :
Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
(* Forward declaration, to be filled in by Typeclass.class_structure *)
let type_object =
ref (fun env s -> assert false :
Env.t -> Location.t -> Parsetree.class_structure ->
class_structure * class_signature * string list)
(*
Saving and outputting type information.
@ -523,7 +528,8 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
(pat, pv, val_env, met_env)
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
let type_self_pattern cl_num val_env met_env par_env spat =
let type_self_pattern cl_num privty val_env met_env par_env spat =
let spat =
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
"selfpat-" ^ cl_num))
@ -540,7 +546,7 @@ let type_self_pattern cl_num val_env met_env par_env spat =
(fun (id, ty) (val_env, met_env, par_env) ->
(Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
Env.add_value id {val_type = ty;
val_kind = Val_self (meths, vars, cl_num)}
val_kind = Val_self (meths, vars, cl_num, privty)}
met_env,
Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
pv (val_env, met_env, par_env)
@ -583,7 +589,20 @@ let rec is_nonexpansive exp =
is_nonexpansive ifso && is_nonexpansive_opt ifnot
| Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
true
| Texp_lazy e -> true
(* Note: nonexpansive only means no _observable_ side effects *)
| Texp_lazy e -> is_nonexpansive e
| Texp_object ({cl_field=fields}, {cty_vars=vars}, _) ->
let count = ref 0 in
List.for_all
(function
Cf_meth _ -> true
| Cf_val (_,_,e) -> incr count; is_nonexpansive e
| Cf_init e -> is_nonexpansive e
| Cf_inher _ | Cf_let _ -> false)
fields &&
Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
vars true &&
!count = 0
| _ -> false
and is_nonexpansive_opt = function
@ -796,7 +815,7 @@ let rec type_exp env sexp =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
Texp_instvar(self_path, path)
| Val_self (_, _, cl_num) ->
| Val_self (_, _, cl_num, _) ->
let (path, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
@ -1123,9 +1142,9 @@ let rec type_exp env sexp =
begin try
let (exp, typ) =
match obj.exp_desc with
Texp_ident(path, {val_kind = Val_self (meths, _, _)}) ->
Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) ->
let (id, typ) =
filter_self_method env met Private meths obj.exp_type
filter_self_method env met Private meths privty
in
(Texp_send(obj, Tmeth_val id), typ)
| Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
@ -1138,10 +1157,10 @@ let rec type_exp env sexp =
Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
with
(_, ({val_kind = Val_self (meths, _, _)} as desc)),
(_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
(path, _) ->
let (_, typ) =
filter_self_method env met Private meths obj.exp_type
filter_self_method env met Private meths privty
in
let method_type = newvar () in
let (obj_ty, res_ty) = filter_arrow env method_type "" in
@ -1251,7 +1270,7 @@ let rec type_exp env sexp =
with Not_found ->
raise(Error(sexp.pexp_loc, Outside_class))
with
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _)}),
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
(path_self, _) ->
let type_override (lab, snewval) =
begin try
@ -1318,6 +1337,14 @@ let rec type_exp env sexp =
exp_type = instance (Predef.type_lazy_t arg.exp_type);
exp_env = env;
}
| Pexp_object s ->
let desc, sign, meths = !type_object env sexp.pexp_loc s in
re {
exp_desc = Texp_object (desc, sign, meths);
exp_loc = sexp.pexp_loc;
exp_type = sign.cty_self;
exp_env = env;
}
| Pexp_poly _ ->
assert false

6
typing/typecore.mli
View File

@ -35,7 +35,7 @@ val type_class_arg_pattern:
Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
Env.t * Env.t
val type_self_pattern:
string -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
Typedtree.pattern *
(Ident.t * type_expr) Meths.t ref *
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
@ -102,3 +102,7 @@ val report_error: formatter -> error -> unit
(* Forward declaration, to be filled in by Typemod.type_module *)
val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
(* Forward declaration, to be filled in by Typeclass.class_structure *)
val type_object:
(Env.t -> Location.t -> Parsetree.class_structure ->
Typedtree.class_structure * class_signature * string list) ref

4
typing/typedtree.ml
View File

@ -77,6 +77,7 @@ and expression_desc =
| Texp_assert of expression
| Texp_assertfalse
| Texp_lazy of expression
| Texp_object of class_structure * class_signature * string list
and meth =
Tmeth_name of string
@ -87,7 +88,8 @@ and meth =
and class_expr =
{ cl_desc: class_expr_desc;
cl_loc: Location.t;
cl_type: class_type }
cl_type: class_type;
cl_env: Env.t }
and class_expr_desc =
Tclass_ident of Path.t

4
typing/typedtree.mli
View File

@ -76,6 +76,7 @@ and expression_desc =
| Texp_assert of expression
| Texp_assertfalse
| Texp_lazy of expression
| Texp_object of class_structure * class_signature * string list
and meth =
Tmeth_name of string
@ -86,7 +87,8 @@ and meth =
and class_expr =
{ cl_desc: class_expr_desc;
cl_loc: Location.t;
cl_type: class_type }
cl_type: class_type;
cl_env: Env.t }
and class_expr_desc =
Tclass_ident of Path.t

2
typing/types.ml
View File

@ -91,7 +91,7 @@ and value_kind =
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of (Ident.t * type_expr) Meths.t ref *
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
string
string * type_expr
(* Self *)
| Val_anc of (string * Ident.t) list * string
(* Ancestor *)

2
typing/types.mli
View File

@ -92,7 +92,7 @@ and value_kind =
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
| Val_self of (Ident.t * type_expr) Meths.t ref *
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
string
string * type_expr
(* Self *)
| Val_anc of (string * Ident.t) list * string
(* Ancestor *)