fix + optimize

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

3 files changed, 66 insertions, 66 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 5df274b129..8e0dd57ae2 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -191,8 +191,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top =
 	  (fun init (obj_init, env_init, _) ->
 	    incr i;
 	    Llet(Strict, obj_init,
-		 Lapply(Lvar env_init,
-                        [Lprim(Pfield 3, [Lprim(Pfield !i, [Lvar env])])]),
+		 Lapply(Lvar env_init, [Lprim(Pfield !i, [Lvar env])]),
 		 init))
 	  obj_init inh_init in
       let obj_init = lfunction [env] obj_init in
@@ -319,8 +318,8 @@ 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, req) = oo_add_class tables in
-  let new_ids = Env.diff top_env cl.cl_env in
-  let top = (new_ids = []) && not req in
+  let top = not req in
+  let new_ids = if top then [] else Env.diff top_env cl.cl_env in
   let env2 = Ident.create "env" in
   let subst env lam i0 new_ids' =
     let fv = free_variables lam in
@@ -373,12 +372,20 @@ let transl_class ids cl_id arity pub_meths cl =
   let table = Ident.create "table" in
   let class_init = Ident.create "class_init" in
   let obj_init = Ident.create "obj_init" in
-  let ltable lam =
+  let ltable table lam =
     Llet(Strict, table,
          Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
-  and lclass 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; lambda_unit])))
+  in
+  (* simplification when we are an object (indicated by ids=[]) *)
+  if top && ids = [] then ltable cla (ldirect obj_init) else
+
+  let lclass lam =
     Llet(Strict, class_init, Lfunction(Curried, [cla], cl_init), lam)
-  and lbody =
+  and lbody obj_init =
     Llet(Strict, obj_init, Lapply(Lvar class_init, [Lvar table; lambda_unit]),
          Lsequence(Lapply (oo_prim "init_class", [Lvar table]),
                    Lprim(Pmakeblock(0, Immutable),
@@ -387,7 +394,8 @@ let transl_class ids cl_id arity pub_meths cl =
                           Lvar table;
                           lambda_unit])))
   in
-  if top then ltable (lclass lbody) else
+  if top then ltable table (lclass (lbody obj_init)) else
+
   let env_index = Ident.create "env_index"
   and envs = Ident.create "envs" in
   let lenvs =
@@ -401,11 +409,12 @@ let transl_class ids cl_id arity pub_meths cl =
            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 (_, _, lpath) -> Lprim(Pfield 3, [lpath])) inh_init
   in
   let make_envs lam =
     Llet(StrictOpt, envs,
-         Lprim(Pmakeblock(0, Immutable),
-               lenv :: List.map (fun (_, _, lpath) -> lpath) inh_init),
+         Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs),
          lam)
   and def_ids cla lam =
     Llet(StrictOpt, env2,
@@ -426,23 +435,30 @@ let transl_class ids cl_id arity pub_meths cl =
          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])
+  and lget_env_init cached =
+    Lapply(Lprim(Pfield 0, [Lvar cached]), [lenvs])
+  in
+  let ldirect () =
+    ltable cla (Lsequence (lset_cached 0 (def_ids cla cl_init),
+                           Lapply (oo_prim "init_class", [Lvar cla])))
   in
   lcache (
   Lsequence(
   Lifthenelse(Lprim(Pfield 0, [Lvar cached]), lambda_unit,
-              ltable (
+              if ids = [] then ldirect () else
+              ltable table (
               lclass (
-              Llet (Strict, env_init,
-                    Lapply(Lvar class_init, [Lvar table]),
-                    Lsequence(
-                    Lapply (oo_prim "init_class", [Lvar table]),
-                    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])
-                   ))))))),
+              Lsequence(
+              lset_cached 0 (Lapply(Lvar class_init, [Lvar table])),
+              Lsequence (
+              Lapply (oo_prim "init_class", [Lvar table]),
+              Lsequence(lset_cached 1 (Lvar class_init),
+                        lset_cached 2 (Lvar table))
+             ))))),
   make_envs (
+  if ids = [] then lapply (lget_env_init cached) [lambda_unit] else
   Lprim(Pmakeblock(0, Immutable),
         [Lapply(Lprim(Pfield 0, [Lvar cached]), [lenvs]);
          Lprim(Pfield 1, [Lvar cached]);
@@ -471,14 +487,14 @@ 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 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 *)
 
 open Format
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index a1e368ebfc..b73c51a17e 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -504,6 +504,20 @@ let assert_failed loc =
 (* Translation of expressions *)
 
 let rec transl_exp e =
+  let const_env =
+    (* Whether classes for immediate objects must be cached *)
+    match e.exp_desc with
+      Texp_object _ | Texp_construct _ | Texp_tuple _
+    | Texp_variant _ | Texp_record _ | Texp_array _
+    | Texp_lazy _ -> true
+    | Texp_let(rec_flag, pat_expr_list, body) ->
+        List.for_all (fun (_,e) -> Typecore.is_nonexpansive e) pat_expr_list
+    | _ -> false
+  in
+  if const_env 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
@@ -671,14 +685,11 @@ let rec transl_exp e =
       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])
+      !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
@@ -749,33 +760,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
@@ -893,15 +877,16 @@ 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 true transl_exp e
+(*
+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 true
+      Translobj.oo_wrap expr.exp_env false
         (transl_let rec_flag pat_expr_list) body
+*)
 
 (* Compile an exception definition *)
 
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 41a242e617..33ff4da62b 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -75,10 +75,9 @@ let oo_add_class id =
 
 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
+    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;