add constant sharing and remove class variables

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/fastclass@5940 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 67 insertions, 31 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index a1f2eba355..98d956aca8 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -46,11 +46,11 @@ let lsequence l1 l2 =
 
 let lfield v i = Lprim(Pfield i, [Lvar v])
 
-let transl_label l = Lconst (Const_base (Const_string l))
+let transl_label l = share (Const_base (Const_string l))
 
 let rec transl_meth_list lst =
   if lst = [] then Lconst (Const_pointer 0) else
-  Lconst (Const_block
+  share (Const_block
             (0, List.map (fun lab -> Const_base (Const_string lab)) lst))
 
 let set_inst_var obj id expr =
@@ -174,10 +174,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
 let rec build_object_init_0 cl_table params cl copy_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 copy_env top ids
-      in
-      (inh_init, Translcore.transl_let rec_flag defs obj_init)
+      build_object_init_0 cl_table (vals @ params) cl copy_env top ids
   | _ ->
       let self = Ident.create "self" in
       let obj = if ids = [] then lambda_unit else Lvar self in
@@ -187,10 +184,10 @@ let rec build_object_init_0 cl_table params cl copy_env top ids =
 	if ids = [] then obj_init else lfunction [self] obj_init in
       (inh_init, obj_init)
 
-let build_object_init_0 cl_table params cl copy_env subst_env top ids =
+let build_object_init_0 cl_table cl copy_env subst_env top ids =
   let env = Ident.create "env" in
   let (inh_init, obj_init) =
-    build_object_init_0 cl_table params cl (copy_env env) top ids in
+    build_object_init_0 cl_table [] cl (copy_env env) top ids in
   let obj_init =
     if top then obj_init else
     let i = ref (List.length inh_init + 1) in
@@ -341,6 +338,13 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
            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 :
@@ -530,7 +534,8 @@ let transl_class ids cl_id arity pub_meths cl =
   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 new_ids = if top then [] else Env.diff top_env cl.cl_env 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
@@ -579,7 +584,7 @@ let transl_class ids cl_id arity pub_meths cl =
   (* Now we start compiling the class *)
   let cla = Ident.create "class" in
   let (inh_init, obj_init) =
-    build_object_init_0 cla [] cl copy_env subst_env top ids in
+    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) =
@@ -600,7 +605,7 @@ let transl_class ids cl_id arity pub_meths cl =
                    Lapply(Lvar obj_init, [lambda_unit])))
   in
   (* Simplest case: an object defined at toplevel (ids=[]) *)
-  if top && ids = [] then ltable cla (ldirect obj_init) else
+  if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
 
   let lclass lam =
     Llet(Strict, class_init, Lfunction(Curried, [cla], cl_init), lam)
@@ -609,7 +614,7 @@ let transl_class ids cl_id arity pub_meths cl =
             [transl_meth_list pub_meths; Lvar class_init])
   in
   (* Still easy: a class defined at toplevel *)
-  if top then lclass lbody else
+  if top then llets (lclass lbody) else
 
   (* Now for the hard stuff: prepare for table cacheing *)
   let env_index = Ident.create "env_index"
@@ -662,6 +667,7 @@ let transl_class ids cl_id arity pub_meths cl =
             Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
                       lset cached 0 (Lvar env_init))))
   in
+  llets (
   lcache (
   Lsequence(
   Lifthenelse(lfield cached 0, lambda_unit,
@@ -676,7 +682,7 @@ let transl_class ids cl_id arity pub_meths cl =
         [Lapply(lfield cached 0, [lenvs]);
          lfield cached 1;
          lfield cached 0;
-         lenvs]))))
+         lenvs])))))
 
 (* example:
 module M(X : sig val x : int end) = struct
@@ -692,6 +698,10 @@ module M0 = struct class c = object method x = 0 end end;;
 module M2 = struct class c = object method x = 2 end end;;
 let f x = object method x = x end;;
 let f x y z = object method x = x method s = object method y = y end end;;
+module F(X:sig end) = struct
+  class c = let () = prerr_endline "Hello" in let x = 1 in
+   object method m = x end
+end;;
 *)
 
 let class_stub =
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 33ff4da62b..ea449202eb 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,20 +63,23 @@ 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)
-    in
-    reset_labels ();
-    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 *)
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index dcdf0c1ad1..f0a92b3324 100644
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -12,12 +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.lambda) -> 'a -> Lambda.lambda
+val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
 val oo_add_class: Ident.t -> Env.t * bool
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 9984a71feb..56b04b969e 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) \