diff options
32 files changed, 1184 insertions, 286 deletions
diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex a1c64eef2..8b739e39d 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 4916697c5..b62a2b463 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index e379a87af..dd1f57256 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -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" + 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 - 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]))))) - -let class_stub = - Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit]) + (* Simplest case: an object defined at toplevel (ids=[]) *) + if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + + 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 *) diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index a546b8afc..a17a0b117 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -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;; diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index a47a0c915..49f4bd8ae 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -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 = diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 3ad655b22..8148f9b8a 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -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 diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 55b256b35..da9e5d892 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -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) -> diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 20794b1f4..ea449202e 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -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 + diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index ccff9ade6..f0a92b332 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -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 diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 78316c77e..430d52040 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -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 diff --git a/stdlib/Makefile b/stdlib/Makefile index 9984a71fe..56b04b969 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -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) \ diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 8d5c3cb6a..29e81dc8c 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -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 ****) diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli index 5e945f931..0195d465f 100644 --- a/stdlib/camlinternalOO.mli +++ b/stdlib/camlinternalOO.mli @@ -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} *) diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 930acecf1..c011554d0 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -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)";; diff --git a/tools/addlabels.ml b/tools/addlabels.ml index b34726aef..5a98e161e 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -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 = diff --git a/tools/depend.ml b/tools/depend.ml index 46be7b355..8871d908d 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -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 diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 0a0d71906..f1b637baf 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -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 diff --git a/typing/ctype.ml b/typing/ctype.ml index 682151dd5..17be1316a 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -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 diff --git a/typing/ctype.mli b/typing/ctype.mli index ae4f15dd9..bc0ce50cc 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -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 diff --git a/typing/env.ml b/typing/env.ml index 807d345e0..4ccb7f7e2 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -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' = diff --git a/typing/env.mli b/typing/env.mli index 4f247e6ae..aec0c29da 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -20,6 +20,7 @@ type t val empty: t val initial: t +val diff: t -> t -> Ident.t list (* Lookup by paths *) diff --git a/typing/ident.ml b/typing/ident.ml index 8997600d5..ccc132f09 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -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 diff --git a/typing/ident.mli b/typing/ident.mli index 1bec7fb7a..ccb0ca46f 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -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 diff --git a/typing/printtyp.ml b/typing/printtyp.ml index c17e1fd89..232a32abb 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -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, _, _, _), _ -> diff --git a/typing/typeclass.ml b/typing/typeclass.ml index c2a318bd8..eecc265d3 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -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 fields = List.map Lazy.force (List.rev fields) in - vars := vars_final; - List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) methods; - - {cl_field = fields; - cl_meths = Meths.map (function (id, ty) -> id) !meths}, + 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; - {cty_self = self_type; - cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars; - cty_concr = concr_meths } + (* 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 + 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 + + (* 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))); + + {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") diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 89a6e6b4f..ae7d4325e 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -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 diff --git a/typing/typecore.ml b/typing/typecore.ml index 774469305..47f87cf2c 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -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 diff --git a/typing/typecore.mli b/typing/typecore.mli index 06c479ea6..3511b93b5 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -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 diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 58577c9df..ab05b564d 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -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 diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 4fa213b6f..587b08874 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -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 diff --git a/typing/types.ml b/typing/types.ml index 9954d56c4..81efda3b8 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -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 *) diff --git a/typing/types.mli b/typing/types.mli index 2a52037ee..77164cd5d 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -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 *) |