port to the latest ocaml (2004/06/18)gcaml

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

23 files changed, 330 insertions, 190 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index cdc4c9e287..8a8652488c 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -409,20 +409,27 @@ let rec comp_expr env exp sz cont =
             (Kpush :: comp_expr env func (sz + 3 + nargs)
                       (Kapply nargs :: cont1))
         end
-  | Lsend(met, obj, args) ->
+  | Lsend(kind, met, obj, args) ->
+      let args = if kind = Cached then List.tl args else args in
       let nargs = List.length args + 1 in
+      let getmethod, args' =
+        if kind = Self then (Kgetmethod, met::obj::args) else
+        match met with
+          Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args)
+        | _ -> (Kgetdynmet, met::obj::args)
+      in
       if is_tailcall cont then
-        comp_args env (met::obj::args) sz
-          (Kgetmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
+        comp_args env args' sz
+          (getmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
       else
         if nargs < 4 then
-          comp_args env (met::obj::args) sz
-            (Kgetmethod :: Kapply nargs :: cont)
+          comp_args env args' sz
+            (getmethod :: Kapply nargs :: cont)
         else begin
           let (lbl, cont1) = label_code cont in
           Kpush_retaddr lbl ::
-          comp_args env (met::obj::args) (sz + 3)
-            (Kgetmethod :: Kapply nargs :: cont1)
+          comp_args env args' (sz + 3)
+            (getmethod :: Kapply nargs :: cont1)
         end
   | Lfunction(kind, params, body) -> (* assume kind = Curried *)
       let lbl = new_label() in
@@ -714,7 +721,7 @@ let rec comp_expr env exp sz cont =
           let info =
             match lam with
               Lapply(_, args)   -> Event_return (List.length args)
-            | Lsend(_, _, args) -> Event_return (List.length args + 1)
+            | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
             | _                 -> Event_other
           in
           let ev = event (Event_after ty) info in
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 66f844615c..25bf10453e 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -468,35 +468,6 @@ let build_custom_runtime prim_name exec_name =
       remove_file
         (Filename.chop_suffix (Filename.basename prim_name) ".c" ^ ".obj");
       retcode
-  | "mrc" ->
-      let cppc = "mrc"
-      and libsppc = "\"{sharedlibraries}MathLib\" \
-                     \"{ppclibraries}PPCCRuntime.o\" \
-                     \"{ppclibraries}PPCToolLibs.o\" \
-                     \"{sharedlibraries}StdCLib\" \
-                     \"{ppclibraries}StdCRuntime.o\" \
-                     \"{sharedlibraries}InterfaceLib\""
-      and linkppc = "ppclink -d"
-      and objsppc = extract ".x" (List.rev !Clflags.ccobjs)
-      and q_prim_name = Filename.quote prim_name
-      and q_exec_name = Filename.quote exec_name
-      in
-      Ccomp.run_command (Printf.sprintf "%s %s %s %s -o %s.x"
-        cppc
-        (Clflags.std_include_flag "-i ")
-        (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts))
-        q_prim_name
-        q_prim_name);
-      Ccomp.run_command ("delete -i " ^ q_exec_name);
-      Ccomp.command (Printf.sprintf
-        "%s -t MPST -c 'MPS ' -o %s %s.x %s %s %s"
-        linkppc
-        q_exec_name
-        q_prim_name
-        (String.concat " " (List.map Filename.quote objsppc))
-        (Filename.quote
-            (Filename.concat Config.standard_library "libcamlrun.x"))
-        libsppc)
   | _ -> assert false
 
 let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 450321ac76..57b8371a5b 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -72,24 +72,37 @@ let relocate_debug base ev =
 
 (* Read the unit information from a .cmo file. *)
 
-let read_unit_info objfile =
-  let ic = open_in_bin objfile in
-  try
-    let buffer = String.create (String.length Config.cmo_magic_number) in
-    really_input ic buffer 0 (String.length Config.cmo_magic_number);
-    if buffer <> Config.cmo_magic_number then
-      raise(Error(Not_an_object_file objfile));
-    let compunit_pos = input_binary_int ic in
-    seek_in ic compunit_pos;
-    let compunit = (input_value ic : compilation_unit) in
-    if compunit.cu_name
-    <> String.capitalize(Filename.basename(chop_extension_if_any objfile))
-    then raise(Error(Illegal_renaming(objfile, compunit.cu_name)));
-    close_in ic;
-    compunit
-  with x ->
-    close_in ic;
-    raise x
+type pack_member_kind = PM_intf | PM_impl of compilation_unit
+
+type pack_member =
+  { pm_file: string;
+    pm_name: string;
+    pm_kind: pack_member_kind }
+
+let read_member_info file =
+  let name =
+    String.capitalize(Filename.basename(chop_extension_if_any file)) in
+  let kind =
+    if Filename.check_suffix file ".cmo" then begin
+    let ic = open_in_bin file in
+    try
+      let buffer = String.create (String.length Config.cmo_magic_number) in
+      really_input ic buffer 0 (String.length Config.cmo_magic_number);
+      if buffer <> Config.cmo_magic_number then
+        raise(Error(Not_an_object_file file));
+      let compunit_pos = input_binary_int ic in
+      seek_in ic compunit_pos;
+      let compunit = (input_value ic : compilation_unit) in
+      if compunit.cu_name <> name
+      then raise(Error(Illegal_renaming(file, compunit.cu_name)));
+      close_in ic;
+      PM_impl compunit
+    with x ->
+      close_in ic;
+      raise x
+    end else
+      PM_intf in
+  { pm_file = file; pm_name = name; pm_kind = kind }
 
 (* Read the bytecode from a .cmo file.
    Write bytecode to channel [oc].
@@ -97,7 +110,7 @@ let read_unit_info objfile =
    Accumulate relocs, debug info, etc.
    Return size of bytecode. *)
 
-let rename_append_bytecode oc mapping defined ofs (objfile, compunit) =
+let rename_append_bytecode oc mapping defined ofs objfile compunit =
   let ic = open_in_bin objfile in
   try
     Bytelink.check_consistency objfile compunit;
@@ -118,23 +131,37 @@ let rename_append_bytecode oc mapping defined ofs (objfile, compunit) =
     close_in ic;
     raise x
 
-(* Same, for a list of .cmo files.  Return total size of bytecode. *)
+(* Same, for a list of .cmo and .cmi files.
+   Return total size of bytecode. *)
 
 let rec rename_append_bytecode_list oc mapping defined ofs = function
     [] ->
       ofs
-  | ((objfile, compunit) as obj_unit) :: rem ->
-      let size = rename_append_bytecode oc mapping defined ofs obj_unit in
-      rename_append_bytecode_list
-        oc mapping (Ident.create_persistent compunit.cu_name :: defined)
-        (ofs + size) rem
+  | m :: rem ->
+      match m.pm_kind with
+      | PM_intf ->
+          rename_append_bytecode_list oc mapping defined ofs rem
+      | PM_impl compunit ->
+          let size =
+            rename_append_bytecode oc mapping defined ofs 
+                                   m.pm_file compunit in
+          rename_append_bytecode_list
+            oc mapping (Ident.create_persistent m.pm_name :: defined)
+            (ofs + size) rem
 
 (* Generate the code that builds the tuple representing the package module *)
 
-let build_global_target oc target_name mapping pos coercion =
+let build_global_target oc target_name members mapping pos coercion =
+  let components =
+    List.map2
+      (fun m (id1, id2) ->
+        match m.pm_kind with
+        | PM_intf -> None
+        | PM_impl _ -> Some id2)
+      members mapping in
   let lam =
-    Translmod.transl_package (List.map snd mapping)
-                             (Ident.create_persistent target_name) coercion in
+    Translmod.transl_package
+      components (Ident.create_persistent target_name) coercion in
   let instrs =
     Bytegen.compile_implementation target_name lam in
   let rel =
@@ -143,11 +170,11 @@ let build_global_target oc target_name mapping pos coercion =
 
 (* Build the .cmo file obtained by packaging the given .cmo files. *)
 
-let package_object_files objfiles targetfile targetname coercion =
-  let units =
-    List.map (fun f -> (f, read_unit_info f)) objfiles in
+let package_object_files files targetfile targetname coercion =
+  let members =
+    map_left_right read_member_info files in
   let unit_names =
-    List.map (fun (_, cu) -> cu.cu_name) units in
+    List.map (fun m -> m.pm_name) members in
   let mapping =
     List.map
       (fun name ->
@@ -160,8 +187,8 @@ let package_object_files objfiles targetfile targetname coercion =
     let pos_depl = pos_out oc in
     output_binary_int oc 0;
     let pos_code = pos_out oc in
-    let ofs = rename_append_bytecode_list oc mapping [] 0 units in
-    build_global_target oc targetname mapping ofs coercion;
+    let ofs = rename_append_bytecode_list oc mapping [] 0 members in
+    build_global_target oc targetname members mapping ofs coercion;
     let pos_debug = pos_out oc in
     if !Clflags.debug && !events <> [] then
       output_value oc (List.rev !events);
@@ -191,7 +218,7 @@ let package_object_files objfiles targetfile targetname coercion =
 (* The entry point *)
 
 let package_files files targetfile =
-  let objfiles =
+  let files =
     List.map
       (fun f ->
         try find_in_path !Config.load_path f
@@ -201,8 +228,8 @@ let package_files files targetfile =
   let targetcmi = prefix ^ ".cmi" in
   let targetname = String.capitalize(Filename.basename prefix) in
   try
-    let coercion = Typemod.package_units objfiles targetcmi targetname in
-    package_object_files objfiles targetfile targetname coercion
+    let coercion = Typemod.package_units files targetcmi targetname in
+    package_object_files files targetfile targetname coercion
   with x ->
     remove_file targetfile; raise x
 
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index a2ee15a820..bd56ca6425 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -293,6 +293,8 @@ let emit_instr = function
   | Kisint -> out opISINT
   | Kisout -> out opULTINT
   | Kgetmethod -> out opGETMETHOD
+  | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
+  | Kgetdynmet -> out opGETDYNMET
   | Kevent ev -> record_event ev
   | Kstop -> out opSTOP
 
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index 81224dde6f..fd13db5d7a 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -97,6 +97,8 @@ type instruction =
   | Kisint
   | Kisout
   | Kgetmethod
+  | Kgetpubmet of int
+  | Kgetdynmet
   | Kevent of debug_event
   | Kstop
 
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index f609d5d94b..fdedd8fd47 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -116,6 +116,8 @@ type instruction =
   | Kisint
   | Kisout
   | Kgetmethod
+  | Kgetpubmet of int
+  | Kgetdynmet
   | Kevent of debug_event
   | Kstop
 
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 9a2770f10d..7f537ddf2b 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -115,6 +115,8 @@ type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt | Variable
 
+type meth_kind = Self | Public | Cached
+
 type shared_code = (int * int) list
 
 type lambda =
@@ -134,7 +136,7 @@ type lambda =
   | Lwhile of lambda * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lassign of Ident.t * lambda
-  | Lsend of lambda * lambda * lambda list
+  | Lsend of meth_kind * lambda * lambda * lambda list
   | Levent of lambda * lambda_event
   | Lifused of Ident.t * lambda
 
@@ -225,7 +227,7 @@ let free_variables l =
       freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
   | Lassign(id, e) ->
       fv := IdentSet.add id !fv; freevars e
-  | Lsend (met, obj, args) ->
+  | Lsend (k, met, obj, args) ->
       List.iter freevars (met::obj::args)
   | Levent (lam, evt) ->
       freevars lam
@@ -309,7 +311,8 @@ let subst_lambda s lam =
   | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
   | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) 
   | Lassign(id, e) -> Lassign(id, subst e)
-  | Lsend (met, obj, args) -> Lsend (subst met, subst obj, List.map subst args)
+  | Lsend (k, met, obj, args) ->
+      Lsend (k, subst met, subst obj, List.map subst args)
   | Levent (lam, evt) -> Levent (subst lam, evt)
   | Lifused (v, e) -> Lifused (v, subst e)
   and subst_decl (id, exp) = (id, subst exp)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index f862ca8aa1..2c7c56e01e 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -124,6 +124,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable
       we can discard e if x does not appear in e'
     Variable: the variable x is assigned later in e' *)
 
+type meth_kind = Self | Public | Cached
+
 type shared_code = (int * int) list     (* stack size -> code label *)
 
 type lambda =
@@ -143,7 +145,7 @@ type lambda =
   | Lwhile of lambda * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lassign of Ident.t * lambda
-  | Lsend of lambda * lambda * lambda list
+  | Lsend of meth_kind * lambda * lambda * lambda list
   | Levent of lambda * lambda_event
   | Lifused of Ident.t * lambda
 
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 3515538bf4..5a1b19e50b 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -376,11 +376,11 @@ let pretty_cases cases =
           prerr_string " " ;
           prerr_string (Format.flush_str_formatter ()))
         ps ;
-(*
+
       prerr_string " -> " ;
       Printlambda.lambda Format.str_formatter l ;
       prerr_string (Format.flush_str_formatter ()) ;
-*)
+
       prerr_endline "")
     cases
 
@@ -778,7 +778,7 @@ let rebuild_nexts arg nexts k =
 (*
   Split a matching.
     Splitting is first directed by or-patterns, then by
-    must test (e.g. constructors)/variable transitions.
+    tests (e.g. constructors)/variable transitions.
 
     The approach is greedy, every split function attempt to
     raise rows as much as possible in the top matrix,
@@ -1778,13 +1778,21 @@ let mk_res get_key env last_choice idef cant_fail ctx =
   fail, klist, jumps
     
 
-(* Aucune optimisation, reflechir apres la release *)
+(*
+     Following two ``failaction'' function compute n, the trap handler
+    to jump to in case of failure of elementary tests
+*)
+
 let mk_failaction_neg partial ctx def = match partial with
 | Partial ->
     begin match def with
     | (_,idef)::_ ->
         Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx
-    | _ -> assert false
+    | _ ->
+       (* Act as Total, this means
+          If no appropriate default matrix exists,
+          then this switch cannot fail *)
+        None, [], jumps_empty
     end
 | Total ->
     None, [], jumps_empty
@@ -2284,7 +2292,7 @@ and do_compile_matching_pr repr partial ctx arg x =
   prerr_string "COMPILE: " ;
   prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ;
   prerr_endline "MATCH" ;
-  pretty_ext x ;
+  pretty_precompiled x ;
   prerr_endline "CTX" ;
   pretty_ctx ctx ;
   let (_, jumps) as r =  do_compile_matching repr partial ctx arg x in
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 763f8fe03a..acbcd6ff8e 100644
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -35,3 +35,7 @@ val for_tupled_function:
 exception Cannot_flatten
 
 val flatten_pattern: int -> pattern -> pattern list
+
+val make_test_sequence:
+        lambda option -> primitive -> primitive -> lambda ->
+        (Asttypes.constant * lambda) list -> lambda
diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
index c4981c95ae..c03523fbcb 100644
--- a/bytecomp/meta.ml
+++ b/bytecomp/meta.ml
@@ -17,6 +17,7 @@ external realloc_global_data : int -> unit = "caml_realloc_global"
 external static_alloc : int -> string = "caml_static_alloc"
 external static_free : string -> unit = "caml_static_free"
 external static_resize : string -> int -> string = "caml_static_resize"
+external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode" 
 type closure = unit -> Obj.t
 external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
 external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli
index de21a36168..3de027f19c 100644
--- a/bytecomp/meta.mli
+++ b/bytecomp/meta.mli
@@ -18,6 +18,7 @@ external global_data : unit -> Obj.t array = "caml_get_global_data"
 external realloc_global_data : int -> unit = "caml_realloc_global"
 external static_alloc : int -> string = "caml_static_alloc"
 external static_free : string -> unit = "caml_static_free"
+external static_release_bytecode : string -> int -> unit = "caml_static_release_bytecode" 
 external static_resize : string -> int -> string = "caml_static_resize"
 type closure = unit -> Obj.t
 external reify_bytecode : string -> int -> closure = "caml_reify_bytecode"
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 8b2ba1e8ca..a7c859d847 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -96,6 +96,8 @@ let instruction ppf = function
   | Kisint -> fprintf ppf "\tisint"
   | Kisout -> fprintf ppf "\tisout"
   | Kgetmethod -> fprintf ppf "\tgetmethod"
+  | Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n
+  | Kgetdynmet -> fprintf ppf "\tgetdynmet"
   | Kstop -> fprintf ppf "\tstop"
   | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname
                                                  ev.ev_char.Lexing.pos_cnum
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index b8af27831c..4f66ddada4 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -274,10 +274,12 @@ let rec lam ppf = function
        lam hi lam body
   | Lassign(id, expr) ->
       fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
-  | Lsend (met, obj, largs) ->
+  | Lsend (k, met, obj, largs) ->
       let args ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
-      fprintf ppf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs
+      let kind =
+        if k = Self then "self" else if k = Cached then "cache" else "" in
+      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
   | Levent(expr, ev) ->
       let kind = 
        match ev.lev_kind with
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index add9ef7cca..ee59cab742 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -75,8 +75,8 @@ let rec eliminate_ref id = function
            dir, eliminate_ref id e3)
   | Lassign(v, e) ->
       Lassign(v, eliminate_ref id e)
-  | Lsend(m, o, el) ->
-      Lsend(eliminate_ref id m, eliminate_ref id o,
+  | Lsend(k, m, o, el) ->
+      Lsend(k, eliminate_ref id m, eliminate_ref id o,
             List.map (eliminate_ref id) el)
   | Levent(l, ev) ->
       Levent(eliminate_ref id l, ev)
@@ -144,7 +144,7 @@ let simplify_exits lam =
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count l
-  | Lsend(m, o, ll) -> List.iter count (m::o::ll)
+  | Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
   | Lifused(v, l) -> count l
 
@@ -250,7 +250,7 @@ let simplify_exits lam =
   | Lfor(v, l1, l2, dir, l3) ->
       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
   | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll)
+  | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
   | Levent(l, ev) -> Levent(simplif l, ev)
   | Lifused(v, l) -> Lifused (v,simplif l)
   in
@@ -313,7 +313,7 @@ let simplify_lets lam =
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count l
-  | Lsend(m, o, ll) -> List.iter count (m::o::ll)
+  | Lsend(_, m, o, ll) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
   | Lifused(v, l) ->
       if count_var v > 0 then count l
@@ -402,7 +402,7 @@ let simplify_lets lam =
   | Lfor(v, l1, l2, dir, l3) ->
       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
   | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll)
+  | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
   | Levent(l, ev) -> Levent(simplif l, ev)
   | Lifused(v, l) ->
       if count_var v > 0 then simplif l else lambda_unit
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index f0109dae31..59153bd677 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -22,7 +22,7 @@ open Translcore
 
 (* XXX Rajouter des evenements... *)
 
-type error = Illegal_class_expr
+type error = Illegal_class_expr | Tags of label * label
 
 exception Error of Location.t * error
 
@@ -103,15 +103,18 @@ let transl_super tbl meths inh_methods rem =
 
 let create_object cl obj init =
   let obj' = Ident.create "self" in
-  let (inh_init, obj_init) = init obj' in
+  let (inh_init, obj_init, has_init) = init obj' in
   if obj_init = lambda_unit then
-   (inh_init,
-    Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
+    (inh_init,
+     Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+                      else"create_object_opt"),
+             [obj; Lvar cl]))
   else begin
    (inh_init,
     Llet(Strict, obj',
             Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
          Lsequence(obj_init,
+                   if not has_init then Lvar obj' else
                    Lapply (oo_prim "run_initializers_opt",
 			   [obj; Lvar obj'; Lvar cl]))))
   end
@@ -129,20 +132,23 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
        Lapply(Lvar obj_init, env @ [obj]))
   | Tclass_structure str ->
       create_object cl_table obj (fun obj ->
-        let (inh_init, obj_init) =
+        let (inh_init, obj_init, has_init) =
           List.fold_right
-            (fun field (inh_init, obj_init) ->
+            (fun field (inh_init, obj_init, has_init) ->
                match field with
                  Cf_inher (cl, _, _) ->
                    let (inh_init, obj_init') =
                      build_object_init cl_table (Lvar obj) [] inh_init
                        (fun _ -> lambda_unit) cl
                    in
-                   (inh_init, lsequence obj_init' obj_init)
+                   (inh_init, lsequence obj_init' obj_init, true)
                | Cf_val (_, id, exp) ->
-                   (inh_init, lsequence (set_inst_var obj id exp) obj_init)
-               | Cf_meth _ | Cf_init _ ->
-                   (inh_init, obj_init)
+                   (inh_init, lsequence (set_inst_var obj id exp) obj_init,
+                    has_init)
+               | Cf_meth _ ->
+                   (inh_init, obj_init, has_init)
+               | Cf_init _ ->
+                   (inh_init, obj_init, true)
                | Cf_let (rec_flag, defs, vals) ->
                    (inh_init,
                     Translcore.transl_let rec_flag defs
@@ -150,15 +156,17 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
                          (fun (id, expr) rem ->
                             lsequence (Lifused(id, set_inst_var obj id expr))
                                       rem)
-                         vals obj_init)))
+                         vals obj_init),
+                    has_init))
             str.cl_field
-            (inh_init, obj_init obj)
+            (inh_init, obj_init obj, false)
         in
         (inh_init,
          List.fold_right
            (fun (id, expr) rem ->
               lsequence (Lifused (id, set_inst_var obj id expr)) rem)
-           params obj_init))
+           params obj_init,
+         has_init))
   | Tclass_fun (pat, vals, cl, partial) ->
       let (inh_init, obj_init) =
         build_object_init cl_table obj (vals @ params) inh_init obj_init cl
@@ -203,16 +211,24 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
       (inh_init, lfunction [env] (subst_env env inh_init obj_init))
 
 
-let bind_method tbl public_methods lab id cl_init =
-  if List.mem lab public_methods then
-    Llet(Alias, id, Lvar (meth lab), cl_init)
-  else
-    Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
-                                [Lvar tbl; transl_label lab]),
-    cl_init)
-
-let bind_methods tbl public_methods meths cl_init =
-  Meths.fold (bind_method tbl public_methods) meths cl_init
+let bind_method tbl lab id cl_init =
+  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+                              [Lvar tbl; transl_label lab]),
+       cl_init)
+
+let bind_methods tbl meths cl_init =
+  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
+  let len = List.length methl in
+  if len < 2 then Meths.fold (bind_method tbl) meths cl_init else
+  let ids = Ident.create "ids" in
+  let i = ref len in
+  Llet(StrictOpt, ids,
+       Lapply (oo_prim "get_method_labels",
+               [Lvar tbl; transl_meth_list (List.map fst methl)]),
+       List.fold_right
+         (fun (lab,id) lam ->
+           decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam))
+         methl cl_init)
 
 let output_methods tbl vals methods lam =
   let lam =
@@ -233,7 +249,7 @@ let rec ignore_cstrs cl =
   | Tclass_apply (cl, _) -> ignore_cstrs cl
   | _ -> cl
 
-let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
+let rec build_class_init cla cstr inh_init cl_init msubst top cl =
   match cl.cl_desc with
     Tclass_ident path ->
       begin match inh_init with
@@ -255,7 +271,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
               Cf_inher (cl, vals, meths) ->
                 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
+                  build_class_init cla false inh_init
                     (transl_vals cla false false vals
                        (transl_super cla str.cl_meths meths cl_init))
                     msubst top cl in
@@ -296,18 +312,18 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
           (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)
+      (inh_init, bind_methods cla str.cl_meths cl_init)
   | Tclass_fun (pat, vals, cl, _) ->
       let (inh_init, cl_init) =
-        build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
+        build_class_init cla cstr inh_init cl_init msubst top cl
       in
       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
       (inh_init, transl_vals cla true false vals cl_init)
   | Tclass_apply (cl, exprs) ->
-      build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
+      build_class_init cla cstr inh_init cl_init msubst top cl
   | Tclass_let (rec_flag, defs, vals, cl) ->
       let (inh_init, cl_init) =
-        build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
+        build_class_init cla cstr inh_init cl_init msubst top cl
       in
       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
       (inh_init, transl_vals cla true false vals cl_init)
@@ -331,7 +347,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
                  cl_init))
       | _ ->
 	  let core cl_init =
-            build_class_init cla pub_meths true inh_init cl_init msubst top cl
+            build_class_init cla true inh_init cl_init msubst top cl
 	  in
 	  if cstr then core cl_init else
           let (inh_init, cl_init) =
@@ -455,8 +471,8 @@ let rec builtin_meths self env env2 body =
         "var", [Lvar n]
     | Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
         "env", [Lvar env2; Lconst(Const_pointer n)]
-    | Lsend(Lvar n, Lvar s, []) when List.mem s self ->
-        "meth", [Lvar n]
+    | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+        "meth", [met]
     | _ -> raise Not_found
   in
   match body with
@@ -470,9 +486,17 @@ let rec builtin_meths self env env2 body =
   | Lapply(f, [p; arg]) when const_path f && const_path p ->
       let s, args = conv arg in
       ("app_const_"^s, f :: p :: args)
-  | Lsend(Lvar n, Lvar s, [arg]) when List.mem s self ->
+  | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
       let s, args = conv arg in
       ("meth_app_"^s, Lvar n :: args)
+  | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+      ("get_meth", [met])
+  | Lsend(Public, met, arg, []) ->
+      let s, args = conv arg in
+      ("send_"^s, met :: args)
+  | Lsend(Cached, met, arg, [_;_]) ->
+      let s, args = conv arg in
+      ("send_"^s, met :: args)
   | Lfunction (Curried, [x], body) ->
       let rec enter self = function
         | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
@@ -512,6 +536,10 @@ module M = struct
     | "meth_app_var"    -> MethAppVar
     | "meth_app_env"    -> MethAppEnv
     | "meth_app_meth"   -> MethAppMeth
+    | "send_const" -> SendConst
+    | "send_var"   -> SendVar
+    | "send_env"   -> SendEnv
+    | "send_meth"  -> SendMeth
     | _ -> assert false
     in Lconst(Const_pointer(Obj.magic tag)) :: args
 end
@@ -604,14 +632,24 @@ let transl_class ids cl_id arity pub_meths cl =
   if not (Translcore.check_recursive_lambda ids obj_init) then
     raise(Error(cl.cl_loc, Illegal_class_expr));
   let (inh_init', cl_init) =
-    build_class_init cla pub_meths true (List.rev inh_init)
-      obj_init msubst top cl
+    build_class_init cla true (List.rev inh_init) obj_init msubst top cl
   in
   assert (inh_init' = []);
   let table = Ident.create "table"
-  and class_init = Ident.create "class_init"
+  and class_init = Ident.create (Ident.name cl_id ^ "_init")
   and env_init = Ident.create "env_init"
   and obj_init = Ident.create "obj_init" in
+  let pub_meths =
+    List.sort
+      (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
+      pub_meths in
+  let tags = List.map Btype.hash_variant pub_meths in
+  let rev_map = List.combine tags pub_meths in
+  List.iter2
+    (fun tag name ->
+      let name' = List.assoc tag rev_map in
+      if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
+    tags pub_meths;
   let ltable table lam =
     Llet(Strict, table,
          Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
@@ -747,3 +785,6 @@ open Format
 let report_error ppf = function
   | Illegal_class_expr ->
       fprintf ppf "This kind of class expression is not allowed"
+  | Tags (lab1, lab2) ->
+      fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
+        lab1 lab2 "Change one of them."
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index a17a0b1178..85d5f74bcd 100644
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -19,7 +19,7 @@ val dummy_class : lambda -> lambda
 val transl_class :
   Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
 
-type error = Illegal_class_expr
+type error = Illegal_class_expr | Tags of string * string
 
 exception Error of Location.t * error
 
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 857ac43879..eab9235b0a 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -573,9 +573,16 @@ let rec transl_exp e =
 and transl_exp0 e =
   match e.exp_desc with
     Texp_ident(path, {val_kind = Val_prim p}) ->
-      if p.prim_name = "%send" then
+      let public_send = p.prim_name = "%send" in
+      if public_send || p.prim_name = "%sendself" then
+        let kind = if public_send then Public else Self in
 	let obj = Ident.create "obj" and meth = Ident.create "meth" in
-	Lfunction(Curried, [obj; meth], Lsend(Lvar meth, Lvar obj, []))
+	Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, []))
+      else if p.prim_name = "%sendcache" then
+	let obj = Ident.create "obj" and meth = Ident.create "meth" in
+        let cache = Ident.create "cache" and pos = Ident.create "pos" in
+	Lfunction(Curried, [obj; meth; cache; pos],
+                  Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos]))
       else
 	transl_primitive p
   | Texp_ident(path, {val_kind = Val_anc _}) ->
@@ -619,17 +626,26 @@ and transl_exp0 e =
     when List.length args = p.prim_arity
     && List.for_all (fun (arg,_) -> arg <> None) args ->
       let args = List.map (function Some x, _ -> x | _ -> assert false) args in
-      if p.prim_name = "%send" then
-	let obj = transl_exp (List.hd args) in
-	event_after e (Lsend (transl_exp (List.nth args 1), obj, []))
-      else let prim = transl_prim p args in
-      begin match (prim, args) with
-        (Praise, [arg1]) ->
-          Lprim(Praise, [event_after arg1 (transl_exp arg1)])
-      | (_, _) ->
-          if primitive_is_ccall prim
-          then event_after e (Lprim(prim, transl_list args))
-          else Lprim(prim, transl_list args)
+      let argl = transl_list args in
+      let public_send = p.prim_name = "%send"
+        || not !Clflags.native_code && p.prim_name = "%sendcache"in
+      if public_send || p.prim_name = "%sendself" then
+        let kind = if public_send then Public else Self in
+	let obj = List.hd argl in
+	event_after e (Lsend (kind, List.nth argl 1, obj, []))
+      else if p.prim_name = "%sendcache" then
+        match argl with [obj; meth; cache; pos] ->
+          event_after e (Lsend(Cached, meth, obj, [cache; pos]))
+        | _ -> assert false
+      else begin
+        let prim = transl_prim p args in
+        match (prim, args) with
+          (Praise, [arg1]) ->
+            Lprim(Praise, [event_after arg1 (List.hd argl)])
+        | (_, _) ->
+            if primitive_is_ccall prim
+            then event_after e (Lprim(prim, argl))
+            else Lprim(prim, argl)
       end
   | Texp_apply(funct, oargs) ->
       event_after e (transl_apply (transl_exp funct) oargs)
@@ -698,7 +714,7 @@ and transl_exp0 e =
       let ll = transl_list expr_list in
       begin try
         (* Deactivate constant optimization if array is small enough *)
-        if List.length ll <= 5 then raise Not_constant;
+        if List.length ll <= 4 then raise Not_constant;
         let cl = List.map extract_constant ll in
         let master =
           match kind with
@@ -707,7 +723,7 @@ and transl_exp0 e =
           | Pfloatarray ->
               Lconst(Const_float_array(List.map extract_float cl))
           | Pgenarray ->
-              assert false in
+              raise Not_constant in             (* can this really happen? *)
         Lprim(Pccall prim_obj_dup, [master])
       with Not_constant ->
         Lprim(Pmakearray kind, ll)
@@ -732,12 +748,16 @@ and transl_exp0 e =
         (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
                      staticfail))
   | Texp_send(expr, met) ->
-      let met_id =
-        match met with
-          Tmeth_name nm -> Translobj.meth nm
-        | Tmeth_val id  -> id
+      let obj = transl_exp expr in
+      let lam =
+        match met with 
+          Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
+        | Tmeth_name nm ->
+            let (tag, cache) = Translobj.meth obj nm in
+	    let kind = if cache = [] then Public else Cached in
+            Lsend (kind, tag, obj, cache)
       in
-      event_after e (Lsend(Lvar met_id, transl_exp expr, []))
+      event_after e lam
   | Texp_new (cl, _) ->
       Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
   | Texp_instvar(path_self, path) ->
@@ -800,10 +820,10 @@ and transl_tupled_cases patl_expr_list =
 and transl_apply lam sargs =
   let lapply funct args =
     match funct with
-      Lsend(lmet, lobj, largs) ->
-        Lsend(lmet, lobj, largs @ args)
-    | Levent(Lsend(lmet, lobj, largs), _) ->
-        Lsend(lmet, lobj, largs @ args)
+      Lsend(k, lmet, lobj, largs) ->
+        Lsend(k, lmet, lobj, largs @ args)
+    | Levent(Lsend(k, lmet, lobj, largs), _) ->
+        Lsend(k, lmet, lobj, largs @ args)
     | Lapply(lexp, largs) ->
         Lapply(lexp, largs @ args)
     | lexp ->
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index e2afb162ba..2da6af3926 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -138,21 +138,21 @@ let init_value modl =
                     [Lvar undef_function_id])
           | _ -> raise Not_found in
         init_v :: init_value_struct env rem
-    | Tsig_type(id, tdecl) :: rem ->
+    | Tsig_type(id, tdecl, _) :: rem ->
         init_value_struct (Env.add_type id tdecl env) rem
     | Tsig_exception(id, edecl) :: rem ->
         transl_exception
           id (Some Predef.path_undefined_recursive_module) edecl ::
         init_value_struct env rem
-    | Tsig_module(id, mty) :: rem ->
+    | Tsig_module(id, mty, _) :: rem ->
         init_value_mod env mty ::
         init_value_struct (Env.add_module id mty env) rem
     | Tsig_modtype(id, minfo) :: rem ->
         init_value_struct (Env.add_modtype id minfo env) rem
-    | Tsig_class(id, cdecl) :: rem ->
+    | Tsig_class(id, cdecl, _) :: rem ->
         Translclass.dummy_class (Lvar undef_function_id) ::
         init_value_struct env rem
-    | Tsig_cltype(id, ctyp) :: rem ->
+    | Tsig_cltype(id, ctyp, _) :: rem ->
         init_value_struct env rem
   in
   try
@@ -550,7 +550,9 @@ let transl_store_implementation module_name (str, restr) =
   primitive_declarations := [];
   let module_id = Ident.create_persistent module_name in
   let (map, prims, size) = build_ident_map restr (defined_idents str) in
-  (size, transl_label_init (transl_store_structure module_id map prims str))
+  transl_store_label_init module_id size
+    (transl_store_structure module_id map prims) str
+  (*size, transl_label_init (transl_store_structure module_id map prims str)*)
 
 (* Compile a toplevel phrase *)
 
@@ -654,15 +656,19 @@ let transl_toplevel_definition str =
 
 (* Compile the initialization code for a packed library *)
 
+let get_component = function
+    None -> Lconst const_unit
+  | Some id -> Lprim(Pgetglobal id, []) 
+
 let transl_package component_names target_name coercion =
   let components =
     match coercion with
       Tcoerce_none ->
-        List.map (fun id -> Lprim(Pgetglobal id, [])) component_names
+        List.map get_component component_names
     | Tcoerce_structure pos_cc_list ->
         let g = Array.of_list component_names in
         List.map
-          (fun (pos, cc) -> apply_coercion cc (Lprim(Pgetglobal g.(pos), [])))
+          (fun (pos, cc) -> apply_coercion cc (get_component g.(pos)))
           pos_cc_list
     | _ ->
         assert false in
@@ -680,7 +686,7 @@ let transl_store_package component_names target_name coercion =
          (fun pos id ->
            Lprim(Psetfield(pos, false),
                  [Lprim(Pgetglobal target_name, []);
-                  Lprim(Pgetglobal id, [])]))
+                  get_component id]))
          0 component_names)
   | Tcoerce_structure pos_cc_list ->
       let id = Array.of_list component_names in
@@ -689,7 +695,7 @@ let transl_store_package component_names target_name coercion =
          (fun dst (src, cc) ->
            Lprim(Psetfield(dst, false),
                  [Lprim(Pgetglobal target_name, []);
-                  apply_coercion cc (Lprim(Pgetglobal id.(src), []))]))
+                  apply_coercion cc (get_component id.(src))]))
          0 pos_cc_list)
   | _ -> assert false
 
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index 14ef3bb926..7a2aa5a0f2 100644
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -22,9 +22,10 @@ val transl_implementation: string -> structure * module_coercion -> lambda
 val transl_store_implementation:
       string -> structure * module_coercion -> int * lambda
 val transl_toplevel_definition: structure -> lambda
-val transl_package: Ident.t list -> Ident.t -> module_coercion -> lambda
+val transl_package: 
+      Ident.t option list -> Ident.t -> module_coercion -> lambda
 val transl_store_package:
-      Ident.t list -> Ident.t -> module_coercion -> int * lambda
+      Ident.t option list -> Ident.t -> module_coercion -> int * lambda
 
 val toplevel_name: Ident.t -> string
 
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index ea449202eb..9899e44b3e 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -13,6 +13,7 @@
 (* $Id$ *)
 
 open Misc
+open Primitive
 open Asttypes
 open Longident
 open Lambda
@@ -44,23 +45,55 @@ let share c =
 
 (* Collect labels *)
 
-let used_methods = ref ([] : (string * Ident.t) list);;
-
-let meth lab =
+let cache_required = ref false
+let method_cache = ref lambda_unit
+let method_count = ref 0
+let method_table = ref []
+
+let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))
+
+let next_cache tag =
+  let n = !method_count in
+  incr method_count;
+  (tag, [!method_cache; Lconst(Const_base(Const_int n))])
+
+let rec is_path = function
+    Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true
+  | Lprim (Pfield _, [lam]) -> is_path lam
+  | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) ->
+      is_path lam1 && is_path lam2
+  | _ -> false
+
+let meth obj lab =
+  let tag = meth_tag lab in
+  if not (!cache_required && !Clflags.native_code) then (tag, []) else
+  if not (is_path obj) then next_cache tag else
   try
-    List.assoc lab !used_methods
+    let r = List.assoc obj !method_table in
+    try
+      (tag, List.assoc tag !r)
+    with Not_found ->
+      let p = next_cache tag in
+      r := p :: !r;
+      p
   with Not_found ->
-    let id = Ident.create lab in
-    used_methods := (lab, id)::!used_methods;
-    id
+    let p = next_cache tag in
+    method_table := (obj, ref [p]) :: !method_table;
+    p
 
 let reset_labels () =
   Hashtbl.clear consts;
-  used_methods := []
+  method_count := 0;
+  method_table := []
 
 (* Insert labels *)
 
 let string s = Lconst (Const_base (Const_string s))
+let int n = Lconst (Const_base (Const_int n))
+
+let prim_makearray =
+  { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
+    prim_native_name = ""; prim_native_float = false }
 
 let transl_label_init expr =
   let expr =
@@ -68,39 +101,41 @@ let transl_label_init expr =
       (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
-    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
 
+let transl_store_label_init glob size f arg =
+  method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
+  let expr = f arg in
+  let (size, expr) =
+    if !method_count = 0 then (size, expr) else
+    (size+1,
+     Lsequence(
+     Lprim(Psetfield(size, false),
+	   [Lprim(Pgetglobal glob, []);
+	    Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
+     expr))
+  in
+  (size, transl_label_init 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)
+  (!top_env, !cache_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
+    if !cache_required then f x else
+    try cache_required := true; let lam = f x in cache_required := false; lam
+    with exn -> cache_required := false; raise exn
   else try
     wrapping := true;
-    required := req;
+    cache_required := req;
     top_env := env;
     classes := [];
     let lambda = f x in
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index f0a92b3324..d6e432da5c 100644
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -17,10 +17,12 @@ open Lambda
 val oo_prim: string -> lambda
 
 val share: structured_constant -> lambda
-val meth: string -> Ident.t
+val meth: lambda -> string -> lambda * lambda list
 
 val reset_labels: unit -> unit
 val transl_label_init: lambda -> lambda
+val transl_store_label_init:
+    Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
 
 val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
 val oo_add_class: Ident.t -> Env.t * bool
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index c931519ee4..8838145468 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -87,7 +87,8 @@ let array_element_kind env ty =
 let array_kind_gen ty env =
   let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in
   match (Ctype.repr array_ty).desc with
-    Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array ->
+    Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
+    when Path.same p Predef.path_array ->
       array_element_kind env elt_ty
   | _ ->
       (* This can happen with e.g. Obj.field *)