cheap class rebind

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

2 files changed, 90 insertions, 5 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 966269dfc3..07e74ecd6b 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -309,6 +309,81 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
    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 _ -> 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));
+    if obj_init' = lfunction [self] obj_init0 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, [Lprim(Pfield 0, [Lvar cla])]);
+           lfunction [table]
+             (Llet(Strict, env_init,
+                   Lapply(Lprim(Pfield 1, [Lvar cla]), [Lvar table]),
+                   lfunction [envs]
+                     (Lapply(Lvar new_init,
+                             [Lapply(Lvar env_init, [Lvar envs])]))));
+           Lprim(Pfield 2, [Lvar cla]);
+           Lprim(Pfield 3, [Lvar cla])])))
+  with Exit ->
+    lambda_unit
+
 (*
    XXX
    Exploiter le fait que les methodes sont definies dans l'ordre pour
@@ -318,6 +393,11 @@ 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 =
+  (* 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
@@ -361,6 +441,7 @@ let transl_class ids cl_id arity pub_meths cl =
 	 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 copy_env subst_env top ids in
@@ -382,7 +463,7 @@ let transl_class ids cl_id arity pub_meths cl =
          Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
                    Lapply(Lvar obj_init, [lambda_unit])))
   in
-  (* simplification when we are an object (indicated by ids=[]) *)
+  (* Simplest case: an object defined at toplevel (ids=[]) *)
   if top && ids = [] then ltable cla (ldirect obj_init) else
 
   let lclass lam =
@@ -396,8 +477,10 @@ let transl_class ids cl_id arity pub_meths cl =
                           Lvar table;
                           lambda_unit])))
   in
+  (* Still easy: a class defined at toplevel *)
   if top then ltable table (lclass (lbody obj_init)) 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 =
diff --git a/parsing/parser.mly b/parsing/parser.mly
index c9d07bf4aa..67a815f4e3 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -595,7 +595,7 @@ class_simple_expr:
   | OBJECT class_structure END
       { mkclass(Pcl_structure($2)) }
   | OBJECT class_structure error
-      { unclosed "class" 1 "end" 3 }
+      { unclosed "object" 1 "end" 3 }
   | LPAREN class_expr COLON class_type RPAREN
       { mkclass(Pcl_constraint($2, $4)) }
   | LPAREN class_expr COLON class_type error
@@ -689,7 +689,7 @@ class_signature:
   | OBJECT class_sig_body END
       { mkcty(Pcty_signature $2) }
   | OBJECT class_sig_body error
-      { unclosed "sig" 1 "end" 3 }
+      { unclosed "object" 1 "end" 3 }
 ;
 class_sig_body:
     class_self_type class_sig_fields
@@ -879,6 +879,10 @@ expr:
       { mkassert $2 }
   | LAZY simple_expr %prec below_SHARP
       { mkexp (Pexp_lazy ($2)) }
+  | OBJECT class_structure END
+      { mkexp (Pexp_object($2)) }
+  | OBJECT class_structure error
+      { unclosed "object" 1 "end" 3 }
 ;
 simple_expr:
     val_longident
@@ -943,8 +947,6 @@ simple_expr:
       { mkexp(Pexp_override []) }
   | simple_expr SHARP label
       { mkexp(Pexp_send($1, $3)) }
-  | OBJECT class_structure END
-      { mkexp (Pexp_object($2)) }
 ;
 simple_labeled_expr_list:
     labeled_simple_expr