Adoption des memes representations que dans ocamlopt pour les tableaux de flottants et les fonctions mutuellement recursives.

Simplification de la compilation du let rec de valeurs.


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

22 files changed, 607 insertions, 222 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 198144913..27a25ed25 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -30,13 +30,19 @@ let new_label () =
 (**** Operations on compilation environments. ****)
 
 let empty_env =
-  { ce_stack = Ident.empty; ce_heap = Ident.empty }
+  { ce_stack = Ident.empty; ce_heap = Ident.empty; ce_rec = Ident.empty }
 
 (* Add a stack-allocated variable *)
 
 let add_var id pos env =
   { ce_stack = Ident.add id pos env.ce_stack;
-    ce_heap = env.ce_heap }
+    ce_heap = env.ce_heap;
+    ce_rec = env.ce_rec }
+
+let rec add_vars idlist pos env =
+  match idlist with
+    [] -> env
+  | id :: rem -> add_vars rem (pos + 1) (add_var id pos env)
 
 (**** Examination of the continuation ****)
 
@@ -186,8 +192,16 @@ and sz_staticfail = ref 0
 
 (* Function bodies that remain to be compiled *)
 
-let functions_to_compile  =
-  (Stack.create () : (Ident.t list * lambda * label * Ident.t list) Stack.t)
+type function_to_compile =
+  { params: Ident.t list;               (* function parameters *)
+    body: lambda;                       (* the function body *)
+    label: label;                       (* the label of the function entry *)
+    free_vars: Ident.t list;            (* free variables of the function *)
+    num_defs: int;            (* number of mutually recursive definitions *)
+    rec_vars: Ident.t list;             (* mutually recursive fn names *)
+    rec_pos: int }                      (* rank in recursive definition *)
+
+let functions_to_compile  = (Stack.create () : function_to_compile Stack.t)
 
 (* Name of current compilation unit (for debugging events) *)
 
@@ -212,6 +226,10 @@ let rec comp_expr env exp sz cont =
         let pos = Ident.find_same id env.ce_heap in
         Kenvacc(pos) :: cont
       with Not_found ->
+      try
+        let ofs = Ident.find_same id env.ce_rec in
+        Koffsetclosure(ofs) :: cont
+      with Not_found ->
         Ident.print id; print_newline();
         fatal_error "Bytegen.comp_expr: var"
       end
@@ -252,40 +270,59 @@ let rec comp_expr env exp sz cont =
   | Lfunction(kind, params, body) -> (* assume kind = Curried *)
       let lbl = new_label() in
       let fv = IdentSet.elements(free_variables exp) in
-      Stack.push (params, body, lbl, fv) functions_to_compile;
+      let to_compile =
+        { params = params; body = body; label = lbl;
+          free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
+      Stack.push to_compile functions_to_compile;
       comp_args env (List.map (fun n -> Lvar n) fv) sz
         (Kclosure(lbl, List.length fv) :: cont)
   | Llet(str, id, arg, body) ->
       comp_expr env arg sz
         (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
           (add_pop 1 cont))
-  | Lletrec(([id, Lfunction(kind, params, funct_body)] as decl), let_body) ->
-      let lbl = new_label() in
-      let fv =
-        IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
-      Stack.push (params, funct_body, lbl, id :: fv) functions_to_compile;
-      comp_args env (List.map (fun n -> Lvar n) fv) sz
-        (Kclosurerec(lbl, List.length fv) :: Kpush ::
-          (comp_expr (add_var id (sz+1) env) let_body (sz+1)
-                     (add_pop 1 cont)))
   | Lletrec(decl, body) ->
       let ndecl = List.length decl in
-      let decl_size =
-        List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
-      let rec comp_decl new_env sz i = function
-          [] ->
-            comp_expr new_env body sz (add_pop ndecl cont)
-        | (id, exp, blocksize) :: rem ->
-            comp_expr new_env exp sz
-              (Kpush :: Kacc i :: Kupdate blocksize ::
-               comp_decl new_env sz (i-1) rem) in
-      let rec comp_init new_env sz = function
-          [] ->
-            comp_decl new_env sz ndecl decl_size
-        | (id, exp, blocksize) :: rem ->
-            Kdummy blocksize :: Kpush ::
-            comp_init (add_var id (sz+1) new_env) (sz+1) rem in
-      comp_init env sz decl_size
+      if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false)
+                      decl then begin
+        (* let rec of functions *)
+        let fv =
+          IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
+        let rec_idents = List.map (fun (id, lam) -> id) decl in
+        let rec comp_fun pos = function
+            [] -> []
+          | (id, Lfunction(kind, params, body)) :: rem ->
+              let lbl = new_label() in
+              let to_compile =
+                { params = params; body = body; label = lbl; free_vars = fv;
+                  num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in
+              Stack.push to_compile functions_to_compile;
+              lbl :: comp_fun (pos + 1) rem
+          | _ -> assert false in
+        let lbls = comp_fun 0 decl in
+        let num_funcs = List.length lbls in
+        comp_args env (List.map (fun n -> Lvar n) fv) sz
+          (Kclosurerec(lbls, List.length fv) ::
+            (comp_expr (add_vars rec_idents (sz+1) env) body (sz + ndecl)
+                       (add_pop ndecl cont)))
+      end else begin
+        let decl_size =
+          List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
+        let rec comp_decl new_env sz i = function
+            [] ->
+              comp_expr new_env body sz (add_pop ndecl cont)
+          | (id, exp, blocksize) :: rem ->
+              comp_expr new_env exp sz
+                (Kpush :: Kacc i :: Kccall("update_dummy", 2) ::
+                 comp_decl new_env sz (i-1) rem) in
+        let rec comp_init new_env sz = function
+            [] ->
+              comp_decl new_env sz ndecl decl_size
+          | (id, exp, blocksize) :: rem ->
+              Kconst(Const_base(Const_int blocksize)) ::
+              Kccall("alloc_dummy", 1) :: Kpush ::
+              comp_init (add_var id (sz+1) new_env) (sz+1) rem in
+        comp_init env sz decl_size
+      end
   | Lprim(Pidentity, [arg]) ->
       comp_expr env arg sz cont
   | Lprim(Pnot, [arg]) ->
@@ -329,6 +366,19 @@ let rec comp_expr env exp sz cont =
     when n >= immed_min & n <= immed_max ->
       let ofs = if prim == Paddint then n else -n in
       comp_expr env arg sz (Koffsetint ofs :: cont)
+  | Lprim(Pmakearray kind, args) ->
+      begin match kind with
+        Pintarray | Paddrarray ->
+          comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
+      | Pfloatarray ->
+          comp_args env args sz (Kmakefloatblock(List.length args) :: cont)
+      | Pgenarray ->
+          if args = []
+          then Kmakeblock(0, 0) :: cont
+          else comp_args env args sz
+                 (Kmakeblock(List.length args, 0) ::
+                  Kccall("make_array", 1) :: cont)
+      end
   | Lprim(p, args) ->
       let instr =
         match p with
@@ -338,8 +388,8 @@ let rec comp_expr env exp sz cont =
         | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag)
         | Pfield n -> Kgetfield n
         | Psetfield(n, ptr) -> Ksetfield n
-        | Pfloatfield n -> Kgetfield n
-        | Psetfloatfield n -> Ksetfield n
+        | Pfloatfield n -> Kgetfloatfield n
+        | Psetfloatfield n -> Ksetfloatfield n
         | Pccall p -> Kccall(p.prim_name, p.prim_arity)
         | Pnegint -> Knegint
         | Paddint -> Kaddint
@@ -374,12 +424,19 @@ let rec comp_expr env exp sz cont =
         | Pstringsets -> Kccall("string_set", 3)
         | Pstringrefu -> Kgetstringchar
         | Pstringsetu -> Ksetstringchar
-        | Pmakearray kind -> Kmakeblock(List.length args, 0)
         | Parraylength kind -> Kvectlength
-        | Parrayrefs kind -> Kccall("array_get", 2)
-        | Parraysets kind -> Kccall("array_set", 3)
-        | Parrayrefu kind -> Kgetvectitem
-        | Parraysetu kind -> Ksetvectitem
+        | Parrayrefs Pgenarray -> Kccall("array_get", 2)
+        | Parrayrefs Pfloatarray -> Kccall("array_get_float", 2)
+        | Parrayrefs _ -> Kccall("array_get_addr", 2)
+        | Parraysets Pgenarray -> Kccall("array_set", 3)
+        | Parraysets Pfloatarray -> Kccall("array_set_float", 3)
+        | Parraysets _ -> Kccall("array_set_addr", 3)
+        | Parrayrefu Pgenarray -> Kccall("array_unsafe_get", 2)
+        | Parrayrefu Pfloatarray -> Kccall("array_unsafe_get_float", 2)
+        | Parrayrefu _ -> Kgetvectitem
+        | Parraysetu Pgenarray -> Kccall("array_unsafe_set", 3)
+        | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3)
+        | Parraysetu _ -> Ksetvectitem
         | Pbittest -> Kccall("bitvect_test", 2)
         | _ -> fatal_error "Bytegen.comp_expr: prim" in
       comp_args env args sz (instr :: cont)
@@ -545,20 +602,21 @@ and comp_binary_test env cond ifso ifnot sz cont =
 
 (**** Compilation of functions ****)
 
-let comp_function (params, fun_body, entry_lbl, free_vars) cont =
-  let arity = List.length params in
-  let rec pos_args pos delta = function
+let comp_function tc cont =
+  let arity = List.length tc.params in
+  let rec positions pos delta = function
       [] -> Ident.empty
-    | id :: rem -> Ident.add id pos (pos_args (pos+delta) delta rem) in
+    | id :: rem -> Ident.add id pos (positions (pos + delta) delta rem) in
   let env =
-    { ce_stack = pos_args arity (-1) params;
-      ce_heap = pos_args 0 1 free_vars } in
+    { ce_stack = positions arity (-1) tc.params;
+      ce_heap = positions (2 * (tc.num_defs - tc.rec_pos) - 1) 1 tc.free_vars;
+      ce_rec = positions (-2 * tc.rec_pos) 2 tc.rec_vars } in
   let cont1 =
-    comp_expr env fun_body arity (Kreturn arity :: cont) in
+    comp_expr env tc.body arity (Kreturn arity :: cont) in
   if arity > 1 then
-    Krestart :: Klabel entry_lbl :: Kgrab(arity - 1) :: cont1
+    Krestart :: Klabel tc.label :: Kgrab(arity - 1) :: cont1
   else
-    Klabel entry_lbl :: cont1
+    Klabel tc.label :: cont1
 
 let comp_remainder cont =
   let c = ref cont in
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 0c6b11ce6..6ade90d71 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -159,7 +159,9 @@ let emit_instr = function
   | Kacc n ->
       if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
   | Kenvacc n ->
-      if n < 4 then out(opENVACC1 + n) else (out opENVACC; out_int (n+1))
+      if n >= 1 && n < 4
+      then out(opENVACC1 + n - 1)
+      else (out opENVACC; out_int n)
   | Kpush ->
       out opPUSH
   | Kpop n ->
@@ -176,7 +178,14 @@ let emit_instr = function
   | Krestart -> out opRESTART
   | Kgrab n -> out opGRAB; out_int n
   | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl
-  | Kclosurerec(lbl, n) -> out opCLOSUREREC; out_int n; out_label lbl
+  | Kclosurerec(lbls, n) ->
+      out opCLOSUREREC; out_int (List.length lbls); out_int n;
+      let org = !out_position in
+      List.iter (out_label_with_orig org) lbls
+  | Koffsetclosure ofs ->
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out (opOFFSETCLOSURE0 + ofs / 2)
+      else (out opOFFSETCLOSURE; out_int ofs)
   | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q
   | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q
   | Kconst sc ->
@@ -205,9 +214,10 @@ let emit_instr = function
       if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
   | Ksetfield n ->
       if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
-  | Kdummy n ->
-      if n = 0 then out opATOM0 else (out opDUMMY; out_int n)
-  | Kupdate n -> out opUPDATE
+  | Kmakefloatblock(n) ->
+      if n = 0 then out opATOM0 else (out opMAKEFLOATBLOCK; out_int n)
+  | Kgetfloatfield n -> out opGETFLOATFIELD; out_int n
+  | Ksetfloatfield n -> out opSETFLOATFIELD; out_int n
   | Kvectlength -> out opVECTLENGTH
   | Kgetvectitem -> out opGETVECTITEM
   | Ksetvectitem -> out opSETVECTITEM
@@ -257,8 +267,14 @@ let rec emit = function
       if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
       emit c
   | Kpush :: Kenvacc n :: c ->
-      if n < 4 then out(opPUSHENVACC1 + n)
-               else (out opPUSHENVACC; out_int (n+1));
+      if n >= 1 && n < 4
+      then out(opPUSHENVACC1 + n - 1)
+      else (out opPUSHENVACC; out_int n);
+      emit c
+  | Kpush :: Koffsetclosure ofs :: c ->
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
+      else (out opPUSHOFFSETCLOSURE; out_int ofs);
       emit c
   | Kpush :: Kgetglobal id :: Kgetfield n :: c ->
       out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
@@ -286,7 +302,7 @@ let rec emit = function
     (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
       emit (Kpush :: instr1 :: instr2 :: ev :: c)
   | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
-    (Kacc _ | Kenvacc _ | Kgetglobal _ | Kconst _ as instr) :: c ->
+    (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
       emit (Kpush :: instr :: ev :: c)
   | Kgetglobal id :: Kgetfield n :: c ->
       out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index d37523d59..7357d1f86 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -15,8 +15,8 @@ open Lambda
 
 type compilation_env =
   { ce_stack: int Ident.tbl;
-    ce_heap: int Ident.tbl }
-
+    ce_heap: int Ident.tbl;
+    ce_rec: int Ident.tbl }
 
 type debug_event =
   { mutable ev_pos: int;                (* Position in bytecode *)
@@ -60,15 +60,17 @@ type instruction =
   | Krestart
   | Kgrab of int                        (* number of arguments *)
   | Kclosure of label * int
-  | Kclosurerec of label * int
+  | Kclosurerec of label list * int
+  | Koffsetclosure of int
   | Kgetglobal of Ident.t
   | Ksetglobal of Ident.t
   | Kconst of structured_constant
   | Kmakeblock of int * int             (* size, tag *)
+  | Kmakefloatblock of int
   | Kgetfield of int
   | Ksetfield of int
-  | Kdummy of int
-  | Kupdate of int
+  | Kgetfloatfield of int
+  | Ksetfloatfield of int
   | Kvectlength
   | Kgetvectitem
   | Ksetvectitem
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index 73aaa7309..a0050b1b0 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -19,13 +19,19 @@ open Lambda
 
 type compilation_env =
   { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
-    ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *)
+    ce_heap: int Ident.tbl;  (* Structure of the heap-allocated env *)
+    ce_rec: int Ident.tbl }  (* Functions bound by the same let rec *)
 
 (* The ce_stack component gives locations of variables residing 
    in the stack. The locations are offsets w.r.t. the origin of the
    stack frame.
    The ce_heap component gives the positions of variables residing in the
-   heap-allocated environment. *)
+   heap-allocated environment.
+   The ce_rec component associate offsets to identifiers for functions
+   bound by the same let rec as the current function.  The offsets
+   are used by the OFFSETCLOSURE instruction to recover the closure
+   pointer of the desired function from the env register (which
+   points to the closure for the current function). *)
 
 (* Debugging events *)
 
@@ -73,15 +79,17 @@ type instruction =
   | Krestart
   | Kgrab of int                        (* number of arguments *)
   | Kclosure of label * int
-  | Kclosurerec of label * int
+  | Kclosurerec of label list * int
+  | Koffsetclosure of int
   | Kgetglobal of Ident.t
   | Ksetglobal of Ident.t
   | Kconst of structured_constant
   | Kmakeblock of int * int             (* size, tag *)
+  | Kmakefloatblock of int
   | Kgetfield of int
   | Ksetfield of int
-  | Kdummy of int                       (* block size *)
-  | Kupdate of int                      (* block size *)
+  | Kgetfloatfield of int
+  | Ksetfloatfield of int
   | Kvectlength
   | Kgetvectitem
   | Ksetvectitem
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 57db9264d..e560ffb79 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -57,7 +57,8 @@ let rec name_pattern default = function
 (* To remove aliases and bind named components *)
 
 let any_pat =
-  {pat_desc = Tpat_any; pat_loc = Location.none; pat_type = Ctype.none}
+  { pat_desc = Tpat_any; pat_loc = Location.none;
+    pat_type = Ctype.none; pat_env = Env.empty }
 
 let simplify_matching m =
   match m.args with
@@ -94,18 +95,23 @@ let divide_constant {cases = cl; args = al} =
 
 (* Matching against a constructor *)
 
+let make_field_args binding_kind arg first_pos last_pos argl =
+  let rec make_args pos =
+    if pos > last_pos
+    then argl
+    else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
+  in make_args first_pos
+
 let make_constr_matching cstr = function
     [] -> fatal_error "Matching.make_constr_matching"
   | ((arg, mut) :: argl) ->
-      let (first_pos, last_pos) =
+      let newargs =
         match cstr.cstr_tag with
-          Cstr_constant _ | Cstr_block _ -> (0, cstr.cstr_arity - 1)
-        | Cstr_exception _ -> (1, cstr.cstr_arity) in
-      let rec make_args pos =
-        if pos > last_pos
-        then argl
-        else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
-      {cases = []; args = make_args first_pos}
+          Cstr_constant _ | Cstr_block _ ->
+            make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
+        | Cstr_exception _ ->
+            make_field_args Alias arg 1 cstr.cstr_arity argl in
+      {cases = []; args = newargs}
 
 let divide_constructor {cases = cl; args = al} =
   let rec divide = function
@@ -205,6 +211,24 @@ let divide_orpat = function
   | _ ->
     fatal_error "Matching.divide_orpat"
 
+(* Matching against an array pattern *)
+
+let make_array_matching len = function
+    [] -> fatal_error "Matching.make_array_matching"
+  | ((arg, mut) :: argl) ->
+      {cases = []; args = make_field_args StrictOpt arg 0 (len - 1) argl}
+
+let divide_array {cases = cl; args = al} =
+  let rec divide = function
+      ({pat_desc = Tpat_array(args)} :: patl, action) :: rem ->
+        let len = List.length args in
+        let (constructs, others) = divide rem in
+        (add (make_array_matching len) constructs len (args @ patl, action) al,
+         others)
+    | cl ->
+      ([], {cases = cl; args = al})
+  in divide cl
+
 (* To combine sub-matchings together *)
 
 let combine_var (lambda1, total1) (lambda2, total2) =
@@ -321,7 +345,7 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
                         sw_blocks = nonconsts;
                         sw_checked = false}) in
     if total1
-     & List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
+    && List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
     then (lambda1, true)
     else (Lcatch(lambda1, lambda2), total2)
   end
@@ -329,6 +353,23 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
 let combine_orpat (lambda1, total1) (lambda2, total2) (lambda3, total3) =
   (Lcatch(Lsequence(lambda1, lambda2), lambda3), total3)
 
+let combine_array kind arg (len_lambda_list, total1) (lambda2, total2) =
+  let lambda1 =
+    match len_lambda_list with
+      [] -> Lstaticfail (* does not happen? *)
+    | [n, act] ->
+        Lifthenelse(Lprim(Pintcomp Ceq,
+                          [Lprim(Parraylength kind, [arg]);
+                           Lconst(Const_base(Const_int n))]),
+                    act, Lstaticfail)
+    | _ ->
+        let max_len =
+          List.fold_left (fun m (n, act) -> max m n) 0 len_lambda_list in
+        Lswitch(Lprim(Parraylength kind, [arg]),
+                {sw_numblocks = 0; sw_blocks = []; sw_checked = true;
+                 sw_numconsts = max_len + 1; sw_consts = len_lambda_list}) in
+  (Lcatch(lambda1, lambda2), total2)
+
 (* Insertion of debugging events *)
 
 let rec event_branch repr lam =
@@ -407,6 +448,11 @@ let rec compile_match repr m =
                 let (records, others) = divide_record lbl.lbl_all pm in
                 combine_var (compile_match repr records)
                             (compile_match repr others)
+            | Tpat_array(patl) ->
+                let (arrays, others) = divide_array pm in
+                combine_array (Typeopt.array_pattern_kind pat) newarg
+                              (compile_list arrays)
+                              (compile_match repr others)
             | Tpat_or(pat1, pat2) ->
                 (* Avoid duplicating the code of the action *)
                 let (or_match, remainder_line, others) = divide_orpat pm in
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 40bc61fc2..973813605 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -34,8 +34,9 @@ let instruction = function
   | Kgrab n -> print_string "\tgrab "; print_int n
   | Kclosure(lbl, n) ->
       print_string "\tclosure L"; print_int lbl; print_string ", "; print_int n
-  | Kclosurerec(lbl, n) ->
-      print_string "\tclosurerec L"; print_int lbl;
+  | Kclosurerec(lbls, n) ->
+      print_string "\tclosurerec";
+      List.iter (fun lbl -> print_string " "; print_int lbl) lbls;
       print_string ", "; print_int n
   | Kgetglobal id -> print_string "\tgetglobal "; Ident.print id
   | Ksetglobal id -> print_string "\tsetglobal "; Ident.print id
@@ -44,10 +45,12 @@ let instruction = function
       Printlambda.structured_constant cst; close_box()
   | Kmakeblock(n, m) ->
       print_string "\tmakeblock "; print_int n; print_string ", "; print_int m
+  | Kmakefloatblock(n) ->
+      print_string "\tmakefloatblock "; print_int n
   | Kgetfield n -> print_string "\tgetfield "; print_int n
   | Ksetfield n -> print_string "\tsetfield "; print_int n
-  | Kdummy n -> print_string "\tdummy "; print_int n
-  | Kupdate n -> print_string "\tupdate"; print_int n
+  | Kgetfloatfield n -> print_string "\tgetfloatfield "; print_int n
+  | Ksetfloatfield n -> print_string "\tsetfloatfield "; print_int n
   | Kvectlength -> print_string "\tvectlength"
   | Kgetvectitem -> print_string "\tgetvectitem"
   | Ksetvectitem -> print_string "\tsetvectitem"
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index b575e595c..3f1163e6f 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -169,8 +169,7 @@ let rec transl_const = function
         fields;
       block
   | Const_float_array fields ->
-      transl_const
-        (Const_block(0, List.map (fun f -> Const_base(Const_float f)) fields))
+      Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
 
 (* Build the initial table of globals *)
 
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 02086ad28..96bbbd2f1 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -30,9 +30,8 @@ let rec transl_meth_list =
 
 (* Instance variable initialization *)
 let set_inst_var obj var id expr =
-  Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
-        [Lvar obj; Lvar id; transl_exp expr])
-
+  let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
+  Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr])
 
 let transl_super tbl meths inh_methods rem =
   List.fold_right
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index fa80e415f..fa5323821 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -20,8 +20,8 @@ open Primitive
 open Path
 open Types
 open Typedtree
+open Typeopt
 open Lambda
-open Translobj
 
 type error =
     Illegal_letrec_pat
@@ -139,62 +139,11 @@ let primitives_table = create_hashtable 31 [
   "%array_safe_set", Parraysets Pgenarray;
   "%array_unsafe_get", Parrayrefu Pgenarray;
   "%array_unsafe_set", Parraysetu Pgenarray;
-  "%obj_size", Parraylength Paddrarray;
-  "%obj_field", Parrayrefu Paddrarray;
-  "%obj_set_field", Parraysetu Paddrarray
+  "%obj_size", Parraylength Pgenarray;
+  "%obj_field", Parrayrefu Pgenarray;
+  "%obj_set_field", Parraysetu Pgenarray
 ]
 
-let has_base_type exp base_ty =
-  let exp_ty =
-    Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
-  match (Ctype.repr exp_ty, Ctype.repr base_ty) with
-    {desc = Tconstr(p1, _, _)}, {desc = Tconstr(p2, _, _)} -> Path.same p1 p2
-  | (_, _) -> false
-
-let maybe_pointer arg =
-  not(has_base_type arg Predef.type_int or has_base_type arg Predef.type_char)
-
-let array_element_kind env ty =
-  let ty = Ctype.repr (Ctype.expand_head env ty) in
-  match ty.desc with
-    Tvar ->
-      Pgenarray
-  | Tconstr(p, args, abbrev) ->
-      if Path.same p Predef.path_int || Path.same p Predef.path_char then
-        Pintarray
-      else if Path.same p Predef.path_float then
-        Pfloatarray
-      else if Path.same p Predef.path_string
-           || Path.same p Predef.path_array then
-        Paddrarray
-      else begin
-        try
-          match Env.find_type p env with
-            {type_kind = Type_abstract} ->
-              Pgenarray
-          | {type_kind = Type_variant cstrs}
-            when List.for_all (fun (name, args) -> args = []) cstrs ->
-              Pintarray
-          | {type_kind = _} ->
-              Paddrarray
-        with Not_found ->
-          (* This can happen due to e.g. missing -I options,
-             causing some .cmi files to be unavailable.
-             Maybe we should emit a warning. *)
-          Pgenarray
-      end
-  | _ ->
-      Paddrarray
-
-let array_kind arg =
-  let ty = Ctype.correct_levels arg.exp_type in
-  let array_ty = Ctype.expand_head arg.exp_env ty in
-  match (Ctype.repr array_ty).desc with
-    Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array ->
-      array_element_kind arg.exp_env elt_ty
-  | _ ->
-    fatal_error "Translcore.array_kind"
-
 let prim_makearray =
   { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true;
     prim_native_name = ""; prim_native_float = false }
@@ -258,7 +207,7 @@ let check_recursive_lambda idlist lam =
   let rec check_top = function
       Lfunction(kind, params, body) as funct -> true
     | Lprim(Pmakeblock(tag, mut), args) -> List.for_all check args
-    | Lprim(Pmakearray kind, args) -> List.for_all check args
+    | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all check args
     | Llet(str, id, arg, body) -> check arg & check_top body
     | Lletrec(bindings, body) ->
         List.for_all (fun (id, arg) -> check arg) bindings & check_top body
@@ -272,7 +221,7 @@ let check_recursive_lambda idlist lam =
     | Lletrec(bindings, body) ->
         List.for_all (fun (id, arg) -> check arg) bindings & check body
     | Lprim(Pmakeblock(tag, mut), args) -> List.for_all check args
-    | Lprim(Pmakearray kind, args) -> List.for_all check args
+    | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all check args
     | Levent (lam, _) -> check lam
     | lam ->
         let fv = free_variables lam in
@@ -477,7 +426,7 @@ let rec transl_exp e =
   | Texp_send(expr, met) ->
       let met_id =
         match met with
-          Tmeth_name nm -> meth nm
+          Tmeth_name nm -> Translobj.meth nm
         | Tmeth_val id  -> id
       in
       event_after e (Lsend(Lvar met_id, transl_exp expr, []))
@@ -489,13 +438,14 @@ let rec transl_exp e =
       transl_setinstvar (transl_path path_self) path expr
   | Texp_override(path_self, modifs) ->
       let cpy = Ident.create "copy" in
-      Llet(Strict, cpy, Lapply(oo_prim "copy", [transl_path path_self]),
-      List.fold_right
-        (fun (path, expr) rem ->
-           Lsequence(transl_setinstvar (Lvar cpy) path expr,
-                     rem))
-        modifs
-        (Lvar cpy))
+      Llet(Strict, cpy,
+           Lapply(Translobj.oo_prim "copy", [transl_path path_self]),
+           List.fold_right
+             (fun (path, expr) rem ->
+                Lsequence(transl_setinstvar (Lvar cpy) path expr,
+                          rem))
+             modifs
+             (Lvar cpy))
   | Texp_letmodule(id, modl, body) ->
       Llet(Strict, id, !transl_module Tcoerce_none modl, transl_exp body)
   | _ ->
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index d3a1e1a53..86626fa1d 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -20,7 +20,6 @@ open Typedtree
 open Lambda
 
 val name_pattern: string -> (pattern * 'a) list -> Ident.t
-val maybe_pointer: expression -> bool
 
 val transl_exp: expression -> lambda
 val transl_let:
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
new file mode 100644
index 000000000..921be0a80
--- /dev/null
+++ b/bytecomp/typeopt.ml
@@ -0,0 +1,77 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Misc
+open Asttypes
+open Primitive
+open Path
+open Types
+open Typedtree
+open Lambda
+
+let has_base_type exp base_ty =
+  let exp_ty =
+    Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
+  match (Ctype.repr exp_ty, Ctype.repr base_ty) with
+    {desc = Tconstr(p1, _, _)}, {desc = Tconstr(p2, _, _)} -> Path.same p1 p2
+  | (_, _) -> false
+
+let maybe_pointer arg =
+  not(has_base_type arg Predef.type_int or has_base_type arg Predef.type_char)
+
+let array_element_kind env ty =
+  let ty = Ctype.repr (Ctype.expand_head env ty) in
+  match ty.desc with
+    Tvar ->
+      Pgenarray
+  | Tconstr(p, args, abbrev) ->
+      if Path.same p Predef.path_int || Path.same p Predef.path_char then
+        Pintarray
+      else if Path.same p Predef.path_float then
+        Pfloatarray
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_array then
+        Paddrarray
+      else begin
+        try
+          match Env.find_type p env with
+            {type_kind = Type_abstract} ->
+              Pgenarray
+          | {type_kind = Type_variant cstrs}
+            when List.for_all (fun (name, args) -> args = []) cstrs ->
+              Pintarray
+          | {type_kind = _} ->
+              Paddrarray
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Pgenarray
+      end
+  | _ ->
+      Paddrarray
+
+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 ->
+      array_element_kind env elt_ty
+  | _ ->
+      (* This can happen with e.g. Obj.field *)
+      Pgenarray
+
+let array_kind exp = array_kind_gen exp.exp_type exp.exp_env
+
+let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env
diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli
new file mode 100644
index 000000000..0f4e856a9
--- /dev/null
+++ b/bytecomp/typeopt.mli
@@ -0,0 +1,19 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+val has_base_type : Typedtree.expression -> Types.type_expr -> bool
+val maybe_pointer : Typedtree.expression -> bool
+val array_kind : Typedtree.expression -> Lambda.array_kind
+val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
diff --git a/byterun/Makefile b/byterun/Makefile
index 2d3f157b9..840a52da4 100644
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -13,7 +13,7 @@ OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \
 
 DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
 
-PRIMS=array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
+PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
   intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
   signals.c str.c sys.c terminfo.c callback.c weak.c
 
diff --git a/byterun/alloc.c b/byterun/alloc.c
index 4ea4091b5..d16c39267 100644
--- a/byterun/alloc.c
+++ b/byterun/alloc.c
@@ -94,7 +94,8 @@ value alloc_array(value (*funct)(char *), char ** arr)
     Begin_root(result);
       for (n = 0; n < nbr; n++) {
 	/* The two statements below must be separate because of evaluation
-           order. */
+           order (don't take the address &Field(result, n) before
+           calling funct, which may cause a GC and move result). */
 	v = funct(arr[n]);
 	modify(&Field(result, n), v);
       }
@@ -118,3 +119,28 @@ int convert_flag_list(value list, int *flags)
   }
   return res;
 }
+
+/* For compiling let rec over values */
+
+value alloc_dummy(value size) /* ML */
+{
+  mlsize_t wosize = Int_val(size);
+  value result;
+  mlsize_t i;
+
+  if (wosize == 0) return Atom(0);
+  result = alloc(wosize, 0);
+  for (i = 0; i < wosize; i++) Field(result, i) = Val_int(0);
+  return result;
+}
+
+value update_dummy(value dummy, value newval) /* ML */
+{
+  mlsize_t size, i;
+  size = Wosize_val(newval);
+  Assert (size == Wosize_val(dummy));
+  Tag_val(dummy) = Tag_val(newval);
+  for (i = 0; i < size; i++)
+    modify(&Field(dummy, i), Field(newval, i));
+  return Val_unit;
+}
diff --git a/byterun/array.c b/byterun/array.c
index 3aa4e5791..cc82716aa 100644
--- a/byterun/array.c
+++ b/byterun/array.c
@@ -19,14 +19,42 @@
 #include "misc.h"
 #include "mlvalues.h"
 
-value array_get(value array, value index)   /* ML */
+#ifndef NATIVE_CODE
+
+value array_get_addr(value array, value index) /* ML */
 {
   long idx = Long_val(index);
   if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.get");
   return Field(array, idx);
 }
 
-value array_set(value array, value index, value newval)   /* ML */
+value array_get_float(value array, value index) /* ML */
+{
+  long idx = Long_val(index);
+  double d;
+  value res;
+
+  if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
+    invalid_argument("Array.get");
+  d = Double_field(array, idx);
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
+value array_get(value array, value index)   /* ML */
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_get_float(array, index);
+  else
+    return array_get_addr(array, index);
+}
+
+value array_set_addr(value array, value index, value newval)   /* ML */
 {
   long idx = Long_val(index);
   if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.set");
@@ -34,33 +62,146 @@ value array_set(value array, value index, value newval)   /* ML */
   return Val_unit;
 }
 
-value make_vect(value len, value init)      /* ML */
+value array_set_float(value array, value index, value newval)   /* ML */
+{
+  long idx = Long_val(index);
+  if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
+    invalid_argument("Array.set");
+  Store_double_field(array, idx, Double_val(newval));
+  return Val_unit;
+}
+
+value array_set(value array, value index, value newval)   /* ML */
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_set_float(array, index, newval);
+  else
+    return array_set_addr(array, index, newval);
+}
+
+value array_unsafe_get_float(value array, value index) /* ML */
 {
+  double d;
   value res;
-  mlsize_t size, i;
 
-  size = Long_val(len);
-  if (size > Max_wosize) invalid_argument("Array.make");
+  d = Double_field(array, Long_val(index));
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
 
-  Begin_root(init);
-    if (size == 0) {
-      res = Atom(0);
-    }
-    else if (size < Max_young_wosize) {
-      res = alloc(size, 0);
-      for (i = 0; i < size; i++) Field(res, i) = init;
-    }
-    else if (Is_block(init) && Is_young(init)) {
-      minor_collection();
-      res = alloc_shr(size, 0);
-      for (i = 0; i < size; i++) Field(res, i) = init;
+value array_unsafe_get(value array, value index)   /* ML */
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_unsafe_get_float(array, index);
+  else
+    return Field(array, Long_val(index));
+}
+
+value array_unsafe_set_addr(value array, value index, value newval)   /* ML */
+{
+  long idx = Long_val(index);
+  Modify(&Field(array, idx), newval);
+  return Val_unit;
+}
+
+value array_unsafe_set_float(value array, value index, value newval)   /* ML */
+{
+  Store_double_field(array, Long_val(index), Double_val(newval));
+  return Val_unit;
+}
+
+value array_unsafe_set(value array, value index, value newval)   /* ML */
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_unsafe_set_float(array, index, newval);
+  else
+    return array_unsafe_set_addr(array, index, newval);
+}
+
+#endif
+
+value make_vect(value len, value init) /* ML */
+{
+  value res;
+  mlsize_t size, wsize, i;
+  double d;
+
+  size = Long_val(len);
+  if (size == 0) {
+    res = Atom(0);
+  }
+  else if (Is_block(init) && Tag_val(init) == Double_tag) {
+    d = Double_val(init);
+    wsize = size * Double_wosize;
+    if (wsize > Max_wosize) invalid_argument("Array.new");
+    if (wsize < Max_young_wosize) {
+      res = alloc(wsize, Double_array_tag);
+    } else {
+      res = alloc_shr(wsize, Double_array_tag);
       res = check_urgent_gc (res);
     }
-    else {
-      res = alloc_shr(size, 0);
-      for (i = 0; i < size; i++) initialize(&Field(res, i), init);
-      res = check_urgent_gc (res);
+    for (i = 0; i < size; i++) {
+      Store_double_field(res, i, d);
     }
-  End_roots();
+  } else {
+    if (size > Max_wosize) invalid_argument("Array.new");
+    Begin_root(init);
+      if (size < Max_young_wosize) {
+	res = alloc(size, 0);
+	for (i = 0; i < size; i++) Field(res, i) = init;
+      }
+      else if (Is_block(init) && Is_young(init)) {
+	minor_collection();
+	res = alloc_shr(size, 0);
+	for (i = 0; i < size; i++) Field(res, i) = init;
+	res = check_urgent_gc (res);
+      }
+      else {
+	res = alloc_shr(size, 0);
+	for (i = 0; i < size; i++) initialize(&Field(res, i), init);
+	res = check_urgent_gc (res);
+      }
+    End_roots();
+  }
   return res;
 }
+
+value make_array(value init)    /* ML */
+{
+  mlsize_t wsize, size, i;
+  value v, res;
+
+  size = Wosize_val(init);
+  if (size == 0) {
+    return init;
+  } else {
+    v = Field(init, 0);
+    if (Is_long(v) || Tag_val(v) != Double_tag) {
+      return init;
+    } else {
+      Assert(size < Max_young_wosize);
+      wsize = size * Double_wosize;
+      Begin_root(init);
+        res = alloc(wsize, Double_array_tag);
+	for (i = 0; i < size; i++) {
+	  Store_double_field(res, i, Double_val(Field(init, i)));
+	}
+      End_roots();
+      return res;
+    }
+  }
+}
+
+#ifdef NATIVE_CODE
+
+void array_bound_error(void)
+{
+  fatal_error("Fatal error: out-of-bound access in array or string\n");
+}
+
+#endif
diff --git a/byterun/exec.h b/byterun/exec.h
index a8d81bcf8..7a28867e2 100644
--- a/byterun/exec.h
+++ b/byterun/exec.h
@@ -39,5 +39,5 @@ struct exec_trailer {
 
 /* Magic number for this release */
 
-#define EXEC_MAGIC "Caml1999X002"
+#define EXEC_MAGIC "Caml1999X003"
 
diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 7cdf64547..1ea06568e 100644
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -98,13 +98,15 @@ void thread_code (code_t code, asize_t len)
   l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] =
   l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] =
   l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] =
-  l[MAKEBLOCK3] = l[GETFIELD] = l[SETFIELD] = l[DUMMY] =
+  l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] =
+  l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] =
   l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] =
   l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] =
-  l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = l[OFFSETREF] = 1;
+  l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] =
+  l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1;
 
   /* Instructions with two operands */
-  l[APPTERM] = l[CLOSURE] = l[CLOSUREREC] = l[PUSHGETGLOBALFIELD] =
+  l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] =
   l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = 2;
 
   len /= sizeof(opcode_t);
@@ -120,6 +122,10 @@ void thread_code (code_t code, asize_t len)
       uint32 const_size = sizes & 0xFFFF;
       uint32 block_size = sizes >> 16;
       p += const_size + block_size;
+    } else if (instr == CLOSUREREC) {
+      uint32 nfuncs = *p++;
+      p++;                      /* skip nvars */
+      p += nfuncs;
     } else {
       p += l[instr];
     }
diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
index a4dfb9e45..c53590686 100644
--- a/byterun/instrtrace.c
+++ b/byterun/instrtrace.c
@@ -44,9 +44,11 @@ void disasm_instr(pc)
     case APPTERM1: case APPTERM2: case APPTERM3: case RETURN:
     case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL:
     case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2:
-    case MAKEBLOCK3: case GETFIELD: case SETFIELD: case DUMMY:
+    case MAKEBLOCK3: case MAKEFLOATBLOCK: 
+    case GETFIELD: case SETFIELD: case GETFLOATFIELD: case SETFLOATFIELD:
     case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP:
     case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF:
+    case OFFSETCLOSURE: case PUSHOFFSETCLOSURE:
       printf(" %d\n", pc[0]); break;
       /* Instructions with two operands */
     case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD:
diff --git a/byterun/instruct.h b/byterun/instruct.h
index ec98d8098..4fb5425d8 100644
--- a/byterun/instruct.h
+++ b/byterun/instruct.h
@@ -25,14 +25,16 @@ enum instructions {
   APPTERM, APPTERM1, APPTERM2, APPTERM3, 
   RETURN, RESTART, GRAB,
   CLOSURE, CLOSUREREC,
+  OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE,
+  PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0,
+  PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE,
   GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL,
   ATOM0, ATOM, PUSHATOM0, PUSHATOM,
-  MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3,
-  GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD,
-  SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD,
-  DUMMY, UPDATE,
+  MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK,
+  GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD,
+  SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD,
   VECTLENGTH, GETVECTITEM, SETVECTITEM,
-  GETSTRINGCHAR, SETSTRINGCHAR, 
+  GETSTRINGCHAR, SETSTRINGCHAR,
   BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT,
   PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS,
   C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN,
diff --git a/byterun/intern.c b/byterun/intern.c
index 01a5bc62f..6c79996b1 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -184,7 +184,6 @@ static void intern_rec(value *dest)
       case CODE_DOUBLE_ARRAY8_BIG:
         len = read8u();
       read_double_array:
-#ifdef NATIVE_CODE
         if (sizeof(double) != 8) {
           intern_cleanup();
           invalid_argument("input_value: non-standard floats");
@@ -200,10 +199,6 @@ static void intern_rec(value *dest)
           mlsize_t i;
           for (i = 0; i < len; i++) Reverse_double((value)((double *)v + i));
         }
-#else
-        intern_cleanup();
-        failwith("input_value: cannot read float array");
-#endif
         break;
       case CODE_DOUBLE_ARRAY32_LITTLE:
       case CODE_DOUBLE_ARRAY32_BIG:
diff --git a/byterun/interp.c b/byterun/interp.c
index d9c8802a8..84c396742 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -461,26 +461,60 @@ value interprete(code_t prog, asize_t prog_size)
       if (nvars > 0) *--sp = accu;
       Alloc_small(accu, 1 + nvars, Closure_tag);
       Code_val(accu) = pc + *pc;
+      pc++;
       for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
       sp += nvars;
-      pc++;
       Next;
     }
 
     Instruct(CLOSUREREC): {
+      int nfuncs = *pc++;
       int nvars = *pc++;
       int i;
+      value * p;
       if (nvars > 0) *--sp = accu;
-      Alloc_small(accu, 2 + nvars, Closure_tag);
-      Code_val(accu) = pc + *pc;
-      Field(accu, 1) = Val_int(0);
-      for (i = 0; i < nvars; i++) Field(accu, i + 2) = sp[i];
+      Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag);
+      p = &Field(accu, nfuncs * 2 - 1);
+      for (i = 0; i < nvars; i++) {
+        *p++ = sp[i];
+      }
       sp += nvars;
-      modify(&Field(accu, 1), accu);
-      pc++;
+      p = &Field(accu, 0);
+      *p = (value) (pc + pc[0]);
+      *--sp = accu;
+      p++;
+      for (i = 1; i < nfuncs; i++) {
+        *p = Make_header(i * 2, Infix_tag, Black); /* color irrelevant? */
+        p++;
+        *p = (value) (pc + pc[i]);
+        *--sp = (value) p;
+        p++;
+      }
+      pc += nfuncs;
       Next;
     }
 
+    Instruct(PUSHOFFSETCLOSURE):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSURE):
+      accu = env + *pc++ * sizeof(value); Next;
+
+    Instruct(PUSHOFFSETCLOSUREM2):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSUREM2):
+      accu = env - 2 * sizeof(value); Next;
+    Instruct(PUSHOFFSETCLOSURE0):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSURE0):
+      accu = env; Next;
+    Instruct(PUSHOFFSETCLOSURE2):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSURE2):
+      accu = env + 2 * sizeof(value); Next;
+    
+
+/* Access to global variables */
+
     Instruct(PUSHGETGLOBAL):
       *--sp = accu;
       /* Fallthrough */
@@ -560,6 +594,17 @@ value interprete(code_t prog, asize_t prog_size)
       accu = block;
       Next;
     }
+    Instruct(MAKEFLOATBLOCK): {
+      mlsize_t size = *pc++;
+      mlsize_t i;
+      value block;
+      Alloc_small(block, size * Double_wosize, Double_array_tag);
+      Store_double_field(block, 0, Double_val(accu));
+      for (i = 1; i < size; i++)
+        Store_double_field(block, i, Double_val(*sp++));
+      accu = block;
+      Next;
+    }
 
 /* Access to components of blocks */
 
@@ -573,6 +618,13 @@ value interprete(code_t prog, asize_t prog_size)
       accu = Field(accu, 3); Next;
     Instruct(GETFIELD):
       accu = Field(accu, *pc); pc++; Next;
+    Instruct(GETFLOATFIELD): {
+      double d = Double_field(accu, *pc);
+      Alloc_small(accu, Double_wosize, Double_tag);
+      Double_val(accu) = d;
+      pc++;
+      Next;
+    }
 
     Instruct(SETFIELD0):
       modify_dest = &Field(accu, 0);
@@ -598,33 +650,21 @@ value interprete(code_t prog, asize_t prog_size)
       pc++;
       modify_newval = *sp++;
       goto modify;
-
-/* For recursive definitions */
-
-    Instruct(DUMMY): {
-      int size = *pc++;
-      Alloc_small(accu, size, 0);
-      while (size--) Field(accu, size) = Val_long(0);
-      Next;
-    }
-    Instruct(UPDATE): {
-      value newval = *sp++;
-      mlsize_t size, n;
-      size = Wosize_val(newval);
-      Assert(size == Wosize_val(accu));
-      Tag_val(accu) = Tag_val(newval);
-      for (n = 0; n < size; n++) {
-        modify(&Field(accu, n), Field(newval, n));
-      }
+    Instruct(SETFLOATFIELD):
+      Store_double_field(accu, *pc, Double_val(*sp));
       accu = Val_unit;
+      sp++;
+      pc++;
       Next;
-    }
 
 /* Array operations */
 
-    Instruct(VECTLENGTH):
-      accu = Val_long(Wosize_val(accu));
+    Instruct(VECTLENGTH): {
+      mlsize_t size = Wosize_val(accu);
+      if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize;
+      accu = Val_long(size);
       Next;
+    }
     Instruct(GETVECTITEM):
       accu = Field(accu, Long_val(sp[0]));
       sp += 1;
diff --git a/byterun/reverse.h b/byterun/reverse.h
index 7d112a124..899734004 100644
--- a/byterun/reverse.h
+++ b/byterun/reverse.h
@@ -11,7 +11,7 @@
 
 /* $Id$ */
 
-/* Swap byte-order in 32-bit integers and in words */
+/* Swap byte-order in 32-bit integers and in 64-bit floats */
 
 #ifndef _reverse_
 #define _reverse_
@@ -28,7 +28,7 @@
   _p[2] = _a;                                                                 \
 }
 
-#define Reverse_int64(d) {                                                    \
+#define Reverse_double(d) {                                                   \
   char * _p;                                                                  \
   int _a;                                                                     \
   _p = (char *) (d);                                                          \
@@ -46,7 +46,4 @@
   _p[4] = _a;                                                                 \
 }
 
-#define Reverse_double Reverse_int64
-
-
 #endif /* _reverse_ */