1 files changed, 73 insertions, 12 deletions
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
+