diff options
-rw-r--r-- | bytecomp/translclass.ml | 49 | ||||
-rw-r--r-- | bytecomp/translcore.ml | 18 | ||||
-rw-r--r-- | bytecomp/translcore.mli | 2 | ||||
-rw-r--r-- | bytecomp/translmod.ml | 4 | ||||
-rw-r--r-- | bytecomp/translobj.ml | 21 | ||||
-rw-r--r-- | bytecomp/translobj.mli | 4 | ||||
-rw-r--r-- | parsing/parser.mly | 2 | ||||
-rw-r--r-- | parsing/parsetree.mli | 1 | ||||
-rw-r--r-- | parsing/printast.ml | 3 | ||||
-rw-r--r-- | stdlib/camlinternalOO.ml | 35 | ||||
-rw-r--r-- | stdlib/camlinternalOO.mli | 5 | ||||
-rw-r--r-- | typing/typeclass.ml | 5 | ||||
-rw-r--r-- | typing/typecore.ml | 20 | ||||
-rw-r--r-- | typing/typecore.mli | 4 | ||||
-rw-r--r-- | typing/typedtree.ml | 1 | ||||
-rw-r--r-- | typing/typedtree.mli | 1 |
16 files changed, 146 insertions, 29 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 4edcfbe337..e752fb8a4b 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -183,6 +183,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env i0 = let (inh_init, obj_init) = build_object_init cl_table obj params [] (copy_env env) cl in let obj_init = subst_lambda (subst_env env) obj_init in + let obj_init = lfunction [obj] obj_init in let obj_init = if i0 < 0 then obj_init else let i = ref (i0-1) in @@ -194,7 +195,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env i0 = [Lprim(Pfield 3, [Lprim(Pfield !i, [Lvar env])])]), init)) obj_init inh_init in - let obj_init = lfunction [env; obj] obj_init in + let obj_init = lfunction [env] obj_init in (inh_init, obj_init) let bind_method tbl public_methods lab id cl_init = @@ -317,9 +318,9 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = let transl_class ids cl_id arity pub_meths cl = let tables = Ident.create (Ident.name cl_id ^ "_tables") in - let top_env = oo_add_class tables in + let (top_env, req) = oo_add_class tables in let new_ids = Env.diff top_env cl.cl_env in - let top = (new_ids = []) in + let top = (new_ids = []) && not req in let replicate id = Ident.create (Ident.name id) in let new_ids2 = List.map replicate new_ids in let subst self = @@ -404,30 +405,39 @@ let transl_class ids cl_id arity pub_meths cl = let obj_init2 = Ident.create "obj_init" and env_init = Ident.create "env_init" and env2 = Ident.create "env" - and self = Ident.create "self" in + and cached = Ident.create "cached" in + let inh_keys = + List.map (fun (_,_,lpath) -> Lprim(Pfield 2, [lpath])) inh_init in let lclass lam = Llet(Strict, class_init, - Lfunction(Curried, [cla], def_ids cla cl_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) in - lclass ( + lcache ( Lsequence( - Lifthenelse(Lprim(Pfield 0, [Lvar tables]), Lconst (Const_pointer 0), + Lifthenelse(Lprim(Pfield 0, [Lvar cached]), lambda_unit, ltable ( + lclass ( Llet (Strict, env_init, Lapply(Lvar class_init, [Lvar table]), Lsequence( Lapply (oo_prim "init_class", [Lvar table]), - Lprim( - Psetfield(0, true), - [Lvar tables; - Lprim(Pmakeblock(0,Immutable), - [Lvar table; Lvar env_init])]))))), + Lsequence( + Lprim(Psetfield(0, true), [Lvar cached; Lvar env_init]), + Lsequence( + Lprim(Psetfield(1, true), [Lvar cached; Lvar class_init]), + Lprim(Psetfield(2, true), [Lvar cached; Lvar table]) + ))))))), make_env ( Lprim(Pmakeblock(0, Immutable), - [Lapply(Lprim(Pfield 1, [Lprim(Pfield 0, [Lvar tables])]), [Lvar env]); - Lvar class_init; - Lprim(Pfield 0, [Lprim(Pfield 0, [Lvar tables])]); + [Lapply(Lprim(Pfield 0, [Lvar cached]), [Lvar env]); + Lprim(Pfield 1, [Lvar cached]); + Lprim(Pfield 2, [Lvar cached]); Lvar env])))) (* example: @@ -438,6 +448,10 @@ module M1 = M (struct let x = 3 end);; let o = new M1.c;; let f (x : int) = let module M = struct class c = object method m = x end end in new M.c;; +module F(X : sig class c : object method x : int end end) = + struct class c = object inherit X.c as super method x = super#x + 1 end end;; +module M0 = struct class c = object method x = 0 end end;; +module M2 = struct class c = object method x = 2 end end;; *) let class_stub = @@ -446,10 +460,13 @@ let class_stub = let dummy_class undef_fn = Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"]) +let () = + transl_object := (fun id meths cl -> transl_class [] id 0 meths cl) + (* Wrapper for class compilation *) let transl_class ids cl_id arity pub_meths cl = - oo_wrap cl.cl_env (transl_class ids cl_id arity pub_meths) cl + oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl (* Error report *) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 34a042eb41..a1e368ebfc 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 [ @@ -665,6 +669,16 @@ 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 + let lam = + !transl_object cl meths + { cl_desc = Tclass_structure cs; + cl_loc = e.exp_loc; + cl_type = Tcty_signature cty; + cl_env = e.exp_env } + in + Lapply(Lprim(Pfield 0, [lam]), [lambda_unit]) and transl_list expr_list = List.map transl_exp expr_list @@ -880,13 +894,13 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = (* Wrapper for class compilation *) let transl_exp e = - Translobj.oo_wrap e.exp_env transl_exp e + Translobj.oo_wrap e.exp_env true transl_exp e let transl_let rec_flag pat_expr_list body = match pat_expr_list with [] -> body | (_, expr) :: _ -> - Translobj.oo_wrap expr.exp_env + Translobj.oo_wrap expr.exp_env true (transl_let rec_flag pat_expr_list) body (* Compile an exception definition *) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 3ad655b229..8148f9b8a6 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 3a1cbcbd22..da9e5d892a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -248,7 +248,7 @@ let rec transl_module cc rootpath mexp = transl_structure [] cc rootpath str | Tmod_functor(param, mty, body) -> let bodypath = functor_path rootpath param in - oo_wrap mexp.mod_env + oo_wrap mexp.mod_env true (function | Tcoerce_none -> Lfunction(Curried, [param], @@ -262,7 +262,7 @@ let rec transl_module cc rootpath mexp = fatal_error "Translmod.transl_module") cc | Tmod_apply(funct, arg, ccarg) -> - oo_wrap mexp.mod_env + oo_wrap mexp.mod_env true (apply_coercion cc) (Lapply(transl_module Tcoerce_none None funct, [transl_module ccarg None arg])) diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 60a419bd45..41a242e617 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -65,25 +65,32 @@ let transl_label_init 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 - -let oo_wrap env f x = - if !wrapping then f x else - try + (!top_env, !required) + +let oo_wrap env req f x = + if !wrapping then + if !required || not req then f x else + let old = !required in + try let lam = f x in required := old; lam + with exn -> required := old; 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), - [Lconst(Const_pointer 0)]), + Llet(StrictOpt, id, + Lprim(Pmakeblock(0, Mutable), + [lambda_unit; lambda_unit; lambda_unit]), lambda)) lambda !classes in diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 5cc821bde9..dcdf0c1ad1 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -19,5 +19,5 @@ val meth: string -> Ident.t val reset_labels: unit -> unit val transl_label_init: Lambda.lambda -> Lambda.lambda -val oo_wrap: Env.t -> ('a -> Lambda.lambda) -> 'a -> Lambda.lambda -val oo_add_class: Ident.t -> Env.t +val oo_wrap: Env.t -> bool -> ('a -> Lambda.lambda) -> 'a -> Lambda.lambda +val oo_add_class: Ident.t -> Env.t * bool diff --git a/parsing/parser.mly b/parsing/parser.mly index f95e70a132..25797a3fef 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -879,6 +879,8 @@ expr: { mkassert $2 } | LAZY simple_expr %prec below_SHARP { mkexp (Pexp_lazy ($2)) } + | OBJECT class_structure END + { mkexp (Pexp_object ($2)) } ; simple_expr: val_longident diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index f0da277bfb..d0db6b8483 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -110,6 +110,7 @@ and expression_desc = | Pexp_assertfalse | Pexp_lazy of expression | Pexp_poly of expression * core_type option + | Pexp_object of class_structure (* Value descriptions *) diff --git a/parsing/printast.ml b/parsing/printast.ml index be819a7d46..340917155f 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -292,6 +292,9 @@ and expression i ppf x = line i ppf "Pexp_poly\n"; expression i ppf e; option i core_type ppf cto; + | Pexp_object s -> + line i ppf "Pexp_object"; + class_structure i ppf s and value_description i ppf x = line i ppf "value_description\n"; diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 8d5c3cb6a7..79d8505602 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -457,6 +457,41 @@ let send obj lab = let (buck, elem) = decode lab in (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj +(**** 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 + (**** Statistics ****) type stats = diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli index 5e945f931c..51441b2c2f 100644 --- a/stdlib/camlinternalOO.mli +++ b/stdlib/camlinternalOO.mli @@ -51,6 +51,11 @@ val run_initializers_opt : obj -> obj -> table -> obj val create_object_and_run_initializers : obj -> table -> obj val send : obj -> label -> t +(** {6 Table cache} *) + +type tables +val lookup_tables : tables -> table array -> tables + (** {6 Parameters} *) type params = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index d5f10ccf38..d53895099e 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1244,6 +1244,11 @@ let class_type_declarations env cls = decl, env) +let () = + Typecore.type_object := + (fun env s -> + incr class_num; class_structure (string_of_int !class_num) env env s) + (*******************************) (* Approximate the class declaration as class ['params] id = object end *) diff --git a/typing/typecore.ml b/typing/typecore.ml index 774469305f..150a806b96 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -67,6 +67,10 @@ 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 -> Parsetree.class_structure -> class_structure * class_signature) (* Saving and outputting type information. @@ -1318,6 +1322,22 @@ let rec type_exp env sexp = exp_type = instance (Predef.type_lazy_t arg.exp_type); exp_env = env; } + | Pexp_object s -> + let desc, ({cty_self = sty} as cty) = !type_object env s in + hide_private_methods sty; + close_object sty; + let meths = + List.fold_right + (fun (s,k,_) l -> + if field_kind_repr k = Fpresent then s :: l else l) + (fst (flatten_fields (object_fields sty))) [] + in + re { + exp_desc = Texp_object (desc, cty, meths); + exp_loc = sexp.pexp_loc; + exp_type = sty; + exp_env = env; + } | Pexp_poly _ -> assert false diff --git a/typing/typecore.mli b/typing/typecore.mli index 06c479ea62..34c96b32e5 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -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 -> Parsetree.class_structure -> + Typedtree.class_structure * class_signature) ref diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 4b664b73fa..ab05b564dd 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 diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 3f29b14346..587b088741 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 |