optimize for size

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

3 files changed, 212 insertions, 77 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 5551f881f2..5841ae23a2 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -49,10 +49,8 @@ let lfield v i = Lprim(Pfield i, [Lvar v])
 let transl_label l = Lconst (Const_base (Const_string l))
 
 let rec transl_meth_list lst =
-  Lconst
-    (List.fold_right
-       (fun lab rem -> Const_block (0, [Const_base (Const_string lab); rem]))
-       lst (Const_pointer 0))
+  Lconst (Const_block
+            (0, List.map (fun lab -> Const_base (Const_string lab)) lst))
 
 let set_inst_var obj id expr =
   let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
@@ -68,15 +66,14 @@ let copy_inst_var obj id expr templ offset =
                                                    [Lvar id';
                                                     Lvar offset])])]))
 
-let transl_val tbl create name id rem =
-  Llet(StrictOpt, id, Lapply (oo_prim (if create then "new_variable"
-                                       else           "get_variable"),
-                              [Lvar tbl; transl_label name]),
-       rem)
+let transl_val tbl create name =
+  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
+          [Lvar tbl; transl_label name])
 
 let transl_vals tbl create vals rem =
   List.fold_right
-    (fun (name, id) rem -> transl_val tbl create name id rem)
+    (fun (name, id) rem ->
+      Llet(StrictOpt, id, transl_val tbl create name, rem))
     vals rem
 
 let transl_super tbl meths inh_methods rem =
@@ -216,6 +213,19 @@ let bind_method tbl public_methods lab id cl_init =
 let bind_methods tbl public_methods meths cl_init =
   Meths.fold (bind_method tbl public_methods) meths cl_init
 
+let output_methods tbl vals methods lam =
+  let lam =
+    match methods with
+      [] -> lam
+    | [lab; code] ->
+        lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+    | _ ->
+        lsequence (Lapply(oo_prim "set_methods",
+                         [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+          lam
+  in
+  transl_vals tbl true vals lam
+
 let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
   match cl.cl_desc with
     Tclass_ident path ->
@@ -231,45 +241,54 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
           assert false
       end
   | Tclass_structure str ->
-      let (inh_init, cl_init) =
+      let (inh_init, cl_init, methods, values) =
         List.fold_right
-          (fun field (inh_init, cl_init) ->
+          (fun field (inh_init, cl_init, methods, values) ->
             match field with
               Cf_inher (cl, vals, meths) ->
-                build_class_init cla pub_meths false inh_init
-                  (transl_vals cla false vals
-                     (transl_super cla str.cl_meths meths cl_init))
-                  msubst top cl
+                let cl_init = output_methods cla values methods cl_init in
+                let inh_init, cl_init =
+                  build_class_init cla pub_meths false inh_init
+                    (transl_vals cla false vals
+                       (transl_super cla str.cl_meths meths cl_init))
+                    msubst top cl in
+                (inh_init, cl_init, [], [])
             | Cf_val (name, id, exp) ->
-                (inh_init, transl_val cla true name id cl_init)
+                (inh_init, cl_init, methods, (name, id)::values)
             | Cf_meth (name, exp) ->
-                let met_code = msubst (transl_exp exp) in
+                let met_code = msubst true (transl_exp exp) in
                 let met_code =
-                  if !Clflags.native_code then
+                  if !Clflags.native_code && List.length met_code = 1 then
                     (* Force correct naming of method for profiles *)
                     let met = Ident.create ("method_" ^ name) in
-                    Llet(Strict, met, met_code, Lvar met)
+                    [Llet(Strict, met, List.hd met_code, Lvar met)]
                   else met_code
                 in
-                (inh_init,
-                 Lsequence(Lapply (oo_prim "set_method",
-                                   [Lvar cla;
-                                    Lvar (Meths.find name str.cl_meths);
-                                    met_code]),
+                (inh_init, cl_init,
+                 Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
+                 values)
+                 (*
+                 Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
+                                   Lvar cla ::
+                                   Lvar (Meths.find name str.cl_meths) ::
+                                   met_code),
                            cl_init))
+                  *)
             | Cf_let (rec_flag, defs, vals) ->
                 let vals =
                   List.map (function (id, _) -> (Ident.name id, id)) vals
                 in
-                (inh_init, transl_vals cla true vals cl_init)
+                (inh_init, cl_init, methods, vals @ values)
             | Cf_init exp ->
                 (inh_init,
                  Lsequence(Lapply (oo_prim "add_initializer",
-                                   [Lvar cla; msubst (transl_exp exp)]),
-                           cl_init)))
+                                   Lvar cla :: msubst false (transl_exp exp)),
+                           cl_init),
+                 methods, values))
           str.cl_field
-          (inh_init, cl_init)
+          (inh_init, cl_init, [], [])
       in
+      let cl_init = output_methods cla values methods cl_init in
       (inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
   | Tclass_fun (pat, vals, cl, _) ->
       let (inh_init, cl_init) =
@@ -435,25 +454,53 @@ let rec builtin_meths self env env2 body =
   | Llet(Alias, s', Lvar s, body) when List.mem s self ->
       builtin_meths self env env2 body
   | Lapply(f, [arg]) when const_path f ->
-      let s, args = conv arg in Lapply(oo_prim ("app"^s), f :: args)
+      let s, args = conv arg in ("app"^s, f :: args)
   | Lapply(f, [arg; p]) when const_path f && const_path p ->
       let s, args = conv arg in
-      Lapply(oo_prim ("app"^s^"_const"), f :: args @ [p])
+      ("app"^s^"_const", f :: args @ [p])
   | Lapply(f, [p; arg]) when const_path f && const_path p ->
       let s, args = conv arg in
-      Lapply(oo_prim ("app_const"^s), f :: p :: args)
+      ("app_const"^s, f :: p :: args)
   | Lfunction (Curried, [x], body) ->
       let rec enter self = function
         | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
           when Ident.same x x' && List.mem s self ->
-            Lapply(oo_prim "set_var", [Lvar n])
+            ("set_var", [Lvar n])
         | Llet(Alias, s', Lvar s, body) when List.mem s self ->
             enter (s'::self) body
         | _ -> raise Not_found
       in enter self body
   | Lfunction _ -> raise Not_found
   | _ ->
-      let s, args = conv body in Lapply(oo_prim ("ret"^s), args)
+      let s, args = conv body in ("get"^s, args)
+
+module M = struct
+  open CamlinternalOO
+  let builtin_meths arr self env env2 body =
+    let builtin, args = builtin_meths self env env2 body in
+    if not arr then [Lapply(oo_prim builtin, args)] else
+    let tag = match builtin with
+      "get_const" -> GetConst
+    | "get_var"   -> GetVar
+    | "get_env"   -> GetEnv
+    | "get_meth"  -> GetMeth
+    | "set_var"   -> SetVar
+    | "app_const" -> AppConst
+    | "app_var"   -> AppVar
+    | "app_env"   -> AppEnv
+    | "app_meth"  -> AppMeth
+    | "app_const_const" -> AppConstConst
+    | "app_const_var"   -> AppConstVar
+    | "app_const_env"   -> AppConstEnv
+    | "app_const_meth"  -> AppConstMeth
+    | "app_var_const"   -> AppVarConst
+    | "app_env_const"   -> AppEnvConst
+    | "app_meth_const"  -> AppMethConst
+    | _ -> assert false
+    in Lconst(Const_pointer(Obj.magic tag)) :: args
+end
+open M
+
 
 (*
    XXX
@@ -487,7 +534,7 @@ let transl_class ids cl_id arity pub_meths cl =
       Ident.empty !new_ids'
   in
   let new_ids_meths = ref [] in
-  let msubst = function
+  let msubst arr = function
       Lfunction (Curried, self :: args, body) ->
         let env = Ident.create "env" in
         let body' =
@@ -496,13 +543,14 @@ let transl_class ids cl_id arity pub_meths cl =
         begin try
           (* Doesn't seem to improve size for bytecode *)
           (* if not !Clflags.native_code then raise Not_found; *)
-          builtin_meths [self] env env2 (lfunction args body')
+          builtin_meths arr [self] env env2 (lfunction args body')
         with Not_found ->
-          lfunction (self :: args)
-            (if not (IdentSet.mem env (free_variables body')) then body' else
-             Llet(Alias, env,
-                  Lprim(Parrayrefu Paddrarray, [Lvar self; Lvar env2]), body'))
-          end
+          [lfunction (self :: args)
+             (if not (IdentSet.mem env (free_variables body')) then body' else
+              Llet(Alias, env,
+                   Lprim(Parrayrefu Paddrarray,
+                         [Lvar self; Lvar env2]), body'))]
+        end
       | _ -> assert false
   in
   let new_ids_init = ref [] in
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index ee8d737e11..248f1bc95b 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -328,6 +328,9 @@ let get_method table label =
   table.buckets.(buck).(elem)
 
 let narrow table vars virt_meths concr_meths =
+  let vars = Array.to_list vars
+  and virt_meths = Array.to_list virt_meths
+  and concr_meths = Array.to_list concr_meths in
   let virt_meth_labs = List.map (get_method_label table) virt_meths in
   let concr_meth_labs = List.map (get_method_label table) concr_meths in
   table.previous_states <-
@@ -395,7 +398,7 @@ let add_initializer table f =
 
 let create_table public_methods =
   let table = new_table () in
-  List.iter
+  Array.iter
     (function met ->
        let lab = new_method met in
        table.methods_by_name  <- Meths.add met lab table.methods_by_name;
@@ -494,22 +497,85 @@ let lookup_tables root keys =
 
 (**** builtin methods ****)
 
-let ret_const x obj = x
-let ret_var n (obj : obj) = Array.unsafe_get obj n
-let ret_env env n obj = Obj.field (Array.unsafe_get obj env) n
-let ret_meth n (obj : obj) = Obj.repr (send obj n)
-let set_var n (obj : obj) x = Array.unsafe_set obj n x
-let app_const f x obj = f x
-let app_var f n (obj : obj) = f (Array.unsafe_get obj n)
-let app_env f env n obj = f (Obj.field (Array.unsafe_get obj env) n)
-let app_meth f n obj = f (Obj.repr (send obj n))
-let app_const_const f x y obj = f x y
-let app_const_var f x n obj = f x (Array.unsafe_get obj n)
-let app_const_env f x env n obj = f x (Obj.field (Array.unsafe_get obj env) n)
-let app_const_meth f x n obj = f x (Obj.repr (send obj n))
-let app_var_const f n x (obj : obj) = f (Array.unsafe_get obj n) x
-let app_env_const f env n x obj = f (Obj.field (Array.unsafe_get obj env) n) x
-let app_meth_const f n x obj = f (Obj.repr (send obj n)) x
+type closure = item
+external ret : (obj -> 'a) -> closure = "%identity"
+
+let get_const x = ret (fun obj -> x)
+let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
+let get_env e n = ret (fun obj -> Obj.field (Array.unsafe_get obj e) n)
+let get_meth n  = ret (fun obj -> send obj n)
+let set_var n   = ret (fun obj x -> Array.unsafe_set obj n x)
+let app_const f x = ret (fun obj -> f x)
+let app_var f n   = ret (fun obj -> f (Array.unsafe_get obj n))
+let app_env f e n = ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n))
+let app_meth f n  = ret (fun obj -> f (repr(send obj n)))
+let app_const_const f x y = ret (fun obj -> f x y)
+let app_const_var f x n   = ret (fun obj -> f x (Array.unsafe_get obj n))
+let app_const_meth f x n = ret (fun obj -> f x (repr(send obj n)))
+let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
+let app_meth_const f n x = ret (fun obj -> f (repr(send obj n)) x)
+let app_const_env f x e n =
+  ret (fun obj -> f x (Obj.field (Array.unsafe_get obj e) n))
+let app_env_const f e n x =
+  ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n) x)
+
+type impl =
+    GetConst
+  | GetVar
+  | GetEnv
+  | GetMeth
+  | SetVar
+  | AppConst
+  | AppVar
+  | AppEnv
+  | AppMeth
+  | AppConstConst
+  | AppConstVar
+  | AppConstEnv
+  | AppConstMeth
+  | AppVarConst
+  | AppEnvConst
+  | AppMethConst
+  | Closure of Obj.t
+
+let method_impl i arr =
+  let next () = incr i; magic arr.(!i) in
+  match next() with
+    GetConst -> let x : t = next() in ret (fun obj -> x)
+  | GetVar   -> let n = next() in get_var n
+  | GetEnv   -> let e = next() and n = next() in get_env e n
+  | GetMeth  -> let n = next() in get_meth n
+  | SetVar   -> let n = next() in set_var n
+  | AppConst -> let f = next() and x = next() in ret (fun obj -> f x)
+  | AppVar   -> let f = next() and n = next () in app_var f n
+  | AppEnv   ->
+      let f = next() and e = next() and n = next() in app_env f e n
+  | AppMeth  -> let f = next() and n = next () in app_meth f n
+  | AppConstConst ->
+      let f = next() and x = next() and y = next() in ret (fun obj -> f x y)
+  | AppConstVar ->
+      let f = next() and x = next() and n = next() in app_const_var f x n
+  | AppConstEnv ->
+      let f = next() and x = next() and e = next () and n = next() in
+      app_const_env f x e n
+  | AppConstMeth ->
+      let f = next() and x = next() and n = next() in app_const_meth f x n
+  | AppVarConst ->
+      let f = next() and n = next() and x = next() in app_var_const f n x
+  | AppEnvConst ->
+      let f = next() and e = next () and n = next() and x = next() in
+      app_const_env f e n x
+  | AppMethConst ->
+      let f = next() and n = next() and x = next() in app_meth_const f n x
+  | Closure _ as clo -> magic clo
+
+let set_methods table methods =
+  let len = Array.length methods and i = ref 0 in
+  while !i < len do
+    let label = methods.(!i) and clo = method_impl i methods in
+    set_method table label clo;
+    incr i
+  done
 
 (**** Statistics ****)
 
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 0a947b5386..dddc882907 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -34,11 +34,12 @@ val get_variable : table -> string -> int
 val get_method_label : table -> string -> label
 val get_method : table -> label -> meth
 val set_method : table -> label -> meth -> unit
-val narrow : table -> string list -> string list -> string list -> unit
+val set_methods : table -> label array -> unit
+val narrow : table -> string array -> string array -> string array -> unit
 val widen : table -> unit
 val add_initializer : table -> (obj -> unit) -> unit
 val dummy_table : table
-val create_table : string list -> table
+val create_table : string array -> table
 val init_class : table -> unit
 
 (** {6 Objects} *)
@@ -56,25 +57,45 @@ val send : obj -> label -> t
 type tables
 val lookup_tables : tables -> table array -> tables
 
-(** {6 Builtin methods} *)
+(** {6 Builtins to reduce code size} *)
 
 open Obj
-val ret_const : t -> obj -> t
-val ret_var : int -> obj -> t
-val ret_env : int -> int -> obj -> t
-val ret_meth : label -> obj -> t
-val set_var : int -> obj -> t -> unit
-val app_const : (t -> t) -> t -> obj -> t
-val app_var : (t -> t) -> int -> obj -> t
-val app_env : (t -> t) -> int -> int -> obj -> t
-val app_meth : (t -> t) -> label -> obj -> t
-val app_const_const : (t -> t -> t) -> t -> t -> obj -> t
-val app_const_var : (t -> t -> t) -> t -> int -> obj -> t
-val app_const_env : (t -> t -> t) -> t -> int -> int -> obj -> t
-val app_const_meth : (t -> t -> t) -> t -> label -> obj -> t
-val app_var_const : (t -> t -> t) -> int -> t -> obj -> t
-val app_env_const : (t -> t -> t) -> int -> int -> t -> obj -> t
-val app_meth_const : (t -> t -> t) -> label -> t -> obj -> t
+type closure
+val get_const : t -> closure
+val get_var : int -> closure
+val get_env : int -> int -> closure
+val get_meth : label -> closure
+val set_var : int -> closure
+val app_const : (t -> t) -> t -> closure
+val app_var : (t -> t) -> int -> closure
+val app_env : (t -> t) -> int -> int -> closure
+val app_meth : (t -> t) -> label -> closure
+val app_const_const : (t -> t -> t) -> t -> t -> closure
+val app_const_var : (t -> t -> t) -> t -> int -> closure
+val app_const_env : (t -> t -> t) -> t -> int -> int -> closure
+val app_const_meth : (t -> t -> t) -> t -> label -> closure
+val app_var_const : (t -> t -> t) -> int -> t -> closure
+val app_env_const : (t -> t -> t) -> int -> int -> t -> closure
+val app_meth_const : (t -> t -> t) -> label -> t -> closure
+
+type impl =
+    GetConst
+  | GetVar
+  | GetEnv
+  | GetMeth
+  | SetVar
+  | AppConst
+  | AppVar
+  | AppEnv
+  | AppMeth
+  | AppConstConst
+  | AppConstVar
+  | AppConstEnv
+  | AppConstMeth
+  | AppVarConst
+  | AppEnvConst
+  | AppMethConst
+  | Closure of t
 
 (** {6 Parameters} *)