Creation du module primitive.

Gestion speciale des tableaux de flottants et des records de flottants.


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

8 files changed, 217 insertions, 84 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 26d7385e64..494b267b4b 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -2,6 +2,7 @@
 
 open Misc
 open Asttypes
+open Primitive
 open Typedtree
 open Lambda
 open Instruct
@@ -244,6 +245,8 @@ let rec comp_expr env exp sz cont =
         | Pmakeblock tag -> Kmakeblock(List.length args, tag)
         | Pfield n -> Kgetfield n
         | Psetfield(n, ptr) -> Ksetfield n
+        | Pfloatfield n -> Kgetfield n
+        | Psetfloatfield n -> Ksetfield n
         | Pccall p -> Kccall(p.prim_name, p.prim_arity)
         | Pnegint -> Knegint
         | Paddint -> Kaddint
@@ -273,15 +276,16 @@ let rec comp_expr env exp sz cont =
         | Pfloatcomp Cle -> Kccall("le_float", 2)
         | Pfloatcomp Cge -> Kccall("ge_float", 2)
         | Pstringlength -> Kccall("ml_string_length", 1)
-        | Psafegetstringchar -> Kccall("string_get", 2)
-        | Psafesetstringchar -> Kccall("string_set", 3)
-        | Pgetstringchar -> Kgetstringchar
-        | Psetstringchar -> Ksetstringchar
-        | Pvectlength -> Kvectlength
-        | Psafegetvectitem -> Kccall("array_get", 2)
-        | Psafesetvectitem ptr -> Kccall("array_set", 3)
-        | Pgetvectitem -> Kgetvectitem
-        | Psetvectitem ptr -> Ksetvectitem
+        | Pstringrefs -> Kccall("string_get", 2)
+        | 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
         | Ptranslate tbl -> Ktranslate tbl
         | _ -> fatal_error "Codegen.comp_expr: prim" in
       comp_args env args sz (instr :: cont)
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index e12b6f458f..0425799cb4 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -4,36 +4,55 @@ open Typedtree
 
 type primitive =
     Pidentity
+    (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
+  (* Operations on heap blocks *)
   | Pmakeblock of int
   | Pfield of int
   | Psetfield of int * bool
-  | Pccall of primitive_description
+  | Pfloatfield of int
+  | Psetfloatfield of int
+  (* External call *)
+  | Pccall of Primitive.description
+  (* Exceptions *)
   | Praise
+  (* Boolean operations *)
   | Psequand | Psequor | Pnot
+  (* Integer operations *)
   | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
   | Pandint | Porint | Pxorint
   | Plslint | Plsrint | Pasrint
   | Pintcomp of comparison
   | Poffsetint of int
   | Poffsetref of int
+  (* Float operations *)
   | Pintoffloat | Pfloatofint
   | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
   | Pfloatcomp of comparison
-  | Pstringlength | Pgetstringchar | Psetstringchar
-  | Psafegetstringchar | Psafesetstringchar
-  | Pvectlength | Pgetvectitem | Psetvectitem of bool
-  | Psafegetvectitem | Psafesetvectitem of bool
+  (* String operations *)
+  | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
+  (* Array operations *)
+  | Pmakearray of array_kind
+  | Parraylength of array_kind
+  | Parrayrefu of array_kind
+  | Parraysetu of array_kind
+  | Parrayrefs of array_kind
+  | Parraysets of array_kind
+  (* Compaction of sparse switches *)
   | Ptranslate of (int * int * int) array
 
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge
 
+and array_kind =
+    Pgenarray | Paddrarray | Pintarray | Pfloatarray
+
 type structured_constant =
     Const_base of constant
-  | Const_block of int * structured_constant list
   | Const_pointer of int
+  | Const_block of int * structured_constant list
+  | Const_float_array of string list
 
 type lambda =
     Lvar of Ident.t
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index fbc18cd945..414bdd431a 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -5,36 +5,55 @@ open Typedtree
 
 type primitive =
     Pidentity
+    (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
+  (* Operations on heap blocks *)
   | Pmakeblock of int
   | Pfield of int
   | Psetfield of int * bool
-  | Pccall of primitive_description
+  | Pfloatfield of int
+  | Psetfloatfield of int
+  (* External call *)
+  | Pccall of Primitive.description
+  (* Exceptions *)
   | Praise
+  (* Boolean operations *)
   | Psequand | Psequor | Pnot
+  (* Integer operations *)
   | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
   | Pandint | Porint | Pxorint
   | Plslint | Plsrint | Pasrint
   | Pintcomp of comparison
   | Poffsetint of int
   | Poffsetref of int
+  (* Float operations *)
   | Pintoffloat | Pfloatofint
   | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
   | Pfloatcomp of comparison
-  | Pstringlength | Pgetstringchar | Psetstringchar
-  | Psafegetstringchar | Psafesetstringchar
-  | Pvectlength | Pgetvectitem | Psetvectitem of bool
-  | Psafegetvectitem | Psafesetvectitem of bool
+  (* String operations *)
+  | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
+  (* Array operations *)
+  | Pmakearray of array_kind
+  | Parraylength of array_kind
+  | Parrayrefu of array_kind
+  | Parraysetu of array_kind
+  | Parrayrefs of array_kind
+  | Parraysets of array_kind
+  (* Compaction of sparse switches *)
   | Ptranslate of (int * int * int) array
 
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge
 
+and array_kind =
+    Pgenarray | Paddrarray | Pintarray | Pfloatarray
+
 type structured_constant =
     Const_base of constant
-  | Const_block of int * structured_constant list
   | Const_pointer of int
+  | Const_block of int * structured_constant list
+  | Const_float_array of string list
 
 type lambda =
     Lvar of Ident.t
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 6cc8fd0723..68650f10d6 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -3,6 +3,7 @@
 open Misc
 open Location
 open Asttypes
+open Primitive
 open Typedtree
 open Lambda
 
@@ -124,7 +125,20 @@ let divide_tuple arity {cases = cl; args = al} =
 
 (* Matching against a record pattern *)
 
-let divide_record num_fields {cases = cl; args = al} =
+let make_record_matching all_labels (arg :: argl) =
+  let rec make_args pos =
+    if pos >= Array.length all_labels then argl else begin
+      let lbl = all_labels.(pos) in
+      match lbl.lbl_repres with
+        Record_regular ->
+          Lprim(Pfield lbl.lbl_pos, [arg]) :: make_args(pos + 1)
+      | Record_float ->
+          Lprim(Pfloatfield lbl.lbl_pos, [arg]) :: make_args(pos + 1)
+    end in
+  {cases = []; args = make_args 0}
+
+let divide_record all_labels {cases = cl; args = al} =
+  let num_fields = Array.length all_labels in
   let record_matching_line lbl_pat_list =
     let patv = Array.new num_fields any_pat in
     List.iter (fun (lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
@@ -137,7 +151,7 @@ let divide_record num_fields {cases = cl; args = al} =
     | ({pat_desc = (Tpat_any | Tpat_var _)} :: patl, action) :: rem ->
         add_line (record_matching_line [] @ patl, action) (divide rem)
     | [] ->
-        make_tuple_matching num_fields al
+        make_record_matching all_labels al
   in divide cl
 
 (* To List.combine sub-matchings together *)
@@ -167,7 +181,8 @@ let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
     | Const_string _ ->
         make_test_sequence
           (Pccall{prim_name = "string_equal";
-                  prim_arity = 2; prim_alloc = false})
+                  prim_arity = 2; prim_alloc = false;
+                  prim_native_name = ""; prim_native_float = false})
           arg const_lambda_list
     | Const_float _ ->
         make_test_sequence (Pfloatcomp Ceq) arg const_lambda_list
@@ -252,7 +267,7 @@ let rec compile_match m =
           combine_constructor arg cstr
             (compile_list constrs) (compile_match others)
       | Tpat_record((lbl, _) :: _) ->
-          compile_match (divide_record (Array.length lbl.lbl_all) pm)
+          compile_match (divide_record lbl.lbl_all pm)
 
 (* The entry points *)
 
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 7a31527995..ea1adca143 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -1,5 +1,6 @@
 open Format
 open Asttypes
+open Primitive
 open Typedtree
 open Lambda
 
@@ -25,6 +26,17 @@ let rec structured_constant = function
       close_box();
       print_string "]";
       close_box()
+  | Const_float_array [] ->
+      print_string "[| |]"
+  | Const_float_array (f1 :: fl) ->
+      open_hovbox 1;
+      print_string "[|";
+      open_hovbox 0;
+      print_string f1;
+      List.iter (fun f -> print_space(); print_string f) fl;
+      close_box();
+      print_string "|]";
+      close_box()
 
 let primitive = function
     Pidentity -> print_string "id"
@@ -33,6 +45,8 @@ let primitive = function
   | Pmakeblock tag -> print_string "makeblock "; print_int tag
   | Pfield n -> print_string "field "; print_int n
   | Psetfield(n, _) -> print_string "setfield "; print_int n
+  | Pfloatfield n -> print_string "floatfield "; print_int n
+  | Psetfloatfield n -> print_string "setfloatfield "; print_int n
   | Pccall p -> print_string p.prim_name
   | Praise -> print_string "raise"
   | Psequand -> print_string "&&"
@@ -72,15 +86,16 @@ let primitive = function
   | Pfloatcomp(Cgt) -> print_string ">."
   | Pfloatcomp(Cge) -> print_string ">=."
   | Pstringlength -> print_string "string.length"
-  | Pgetstringchar -> print_string "string.unsafe_get"
-  | Psetstringchar -> print_string "string.unsafe_set"
-  | Psafegetstringchar -> print_string "string.get"
-  | Psafesetstringchar -> print_string "string.set"
-  | Pvectlength -> print_string "array.length"
-  | Pgetvectitem -> print_string "array.unsafe_get"
-  | Psetvectitem _ -> print_string "array.unsafe_set"
-  | Psafegetvectitem -> print_string "array.get"
-  | Psafesetvectitem _ -> print_string "array.set"
+  | Pstringrefu -> print_string "string.unsafe_get"
+  | Pstringsetu -> print_string "string.unsafe_set"
+  | Pstringrefs -> print_string "string.get"
+  | Pstringsets -> print_string "string.set"
+  | Parraylength _ -> print_string "array.length"
+  | Pmakearray _ -> print_string "makearray "
+  | Parrayrefu _ -> print_string "array.unsafe_get"
+  | Parraysetu _ -> print_string "array.unsafe_set"
+  | Parrayrefs _ -> print_string "array.get"
+  | Parraysets _ -> print_string "array.set"
   | Ptranslate tbl ->
       print_string "translate [";
       open_hvbox 0;
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 2a5947e073..f75025b411 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -140,6 +140,9 @@ let rec transl_const = function
         (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
         fields;
       block
+  | Const_float_array fields ->
+      transl_const
+        (Const_block(0, List.map (fun f -> Const_base(Const_float f)) fields))
 
 (* Build the initial table of globals *)
 
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index b7362ea3d2..df476352d6 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -3,6 +3,7 @@
 
 open Misc
 open Asttypes
+open Primitive
 open Path
 open Typedtree
 open Lambda
@@ -67,8 +68,12 @@ and bind_label_pattern env patl arg mut =
   | (lbl, pat) :: rem ->
       let mut1 =
         match lbl.lbl_mut with Mutable -> Mutable | Immutable -> mut in
+      let access =
+        match lbl.lbl_repres with
+          Record_regular -> Pfield lbl.lbl_pos
+        | Record_float -> Pfloatfield lbl.lbl_pos in
       let (env1, bind1) =
-        bind_pattern env pat (Lprim(Pfield lbl.lbl_pos, [arg])) mut1 in
+        bind_pattern env pat (Lprim(access, [arg])) mut1 in
       let (env2, bind2) =
         bind_label_pattern env1 rem arg mut in
       (env2, fun e -> bind1(bind2 e))
@@ -87,36 +92,48 @@ and bind_patterns env patl argl =
 
 let comparisons_table = create_hashtable 11 [
   "%equal",
-      (Pccall{prim_name = "equal"; prim_arity = 2; prim_alloc = false},
+      (Pccall{prim_name = "equal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
        Pintcomp Ceq,
        Pfloatcomp Ceq,
-       Pccall{prim_name = "string_equal"; prim_arity = 2; prim_alloc = false});
+       Pccall{prim_name = "string_equal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false});
   "%notequal",
-      (Pccall{prim_name = "notequal"; prim_arity = 2; prim_alloc = false},
+      (Pccall{prim_name = "notequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
        Pintcomp Cneq,
        Pfloatcomp Cneq,
        Pccall{prim_name = "string_notequal"; prim_arity = 2;
-                                             prim_alloc = false});
+              prim_alloc = false; prim_native_name = ""; 
+              prim_native_float = false});
   "%lessthan",
-      (Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false},
+      (Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false; 
+              prim_native_name = ""; prim_native_float = false},
        Pintcomp Clt,
        Pfloatcomp Clt,
-       Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false});
+       Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false});
   "%greaterthan",
-      (Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false},
+      (Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
        Pintcomp Cgt,
        Pfloatcomp Cgt,
-       Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false});
+       Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false});
   "%lessequal",
-      (Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false},
+      (Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
        Pintcomp Cle,
        Pfloatcomp Cle,
-       Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false});
+       Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false});
   "%greaterequal",
-      (Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false},
+      (Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
        Pintcomp Cge,
        Pfloatcomp Cge,
-       Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false})
+       Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false})
 ]
 
 let primitives_table = create_hashtable 31 [
@@ -165,15 +182,18 @@ let primitives_table = create_hashtable 31 [
   "%gtfloat", Pfloatcomp Cgt;
   "%gefloat", Pfloatcomp Cge;
   "%string_length", Pstringlength;
-  "%string_safe_get", Psafegetstringchar;
-  "%string_safe_set", Psafesetstringchar;
-  "%string_unsafe_get", Pgetstringchar;
-  "%string_unsafe_set", Psetstringchar;
-  "%array_length", Pvectlength;
-  "%array_safe_get", Psafegetvectitem;
-  "%array_safe_set", Psafesetvectitem true;
-  "%array_unsafe_get", Pgetvectitem;
-  "%array_unsafe_set", Psetvectitem true
+  "%string_safe_get", Pstringrefs;
+  "%string_safe_set", Pstringsets;
+  "%string_unsafe_get", Pstringrefu;
+  "%string_unsafe_set", Pstringsetu;
+  "%array_length", Parraylength Pgenarray;
+  "%array_safe_get", Parrayrefs Pgenarray;
+  "%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
 ]
 
 let same_base_type ty1 ty2 =
@@ -182,17 +202,35 @@ let same_base_type ty1 ty2 =
   | (_, _) -> false
 
 let maybe_pointer arg =
-  if same_base_type arg.exp_type Predef.type_int
-  or same_base_type arg.exp_type Predef.type_char
-  then false
-  else true
+  not(same_base_type arg.exp_type Predef.type_int or
+      same_base_type arg.exp_type Predef.type_char)
+
+let array_kind arg =
+  match Ctype.repr arg.exp_type with
+    Tconstr(p, [ty]) ->
+      begin match Ctype.repr ty with
+        Tvar v -> Pgenarray
+      | Tconstr(p, _) ->
+          if Path.same p Predef.path_int or Path.same p Predef.path_char then
+            Pintarray
+          else if Path.same p Predef.path_float then
+            Pfloatarray
+          else
+            Paddrarray
+      | _ -> Paddrarray
+      end
+  | _ -> fatal_error "Translcore.array_kind"
 
 let transl_prim prim args =
   try
     let (gencomp, intcomp, floatcomp, stringcomp) =
       Hashtbl.find comparisons_table prim.prim_name in
     match args with
-      [arg1; arg2] when same_base_type arg1.exp_type Predef.type_int
+      [arg1; {exp_desc = Texp_construct(cstr, [])}] ->
+        intcomp
+    | [{exp_desc = Texp_construct(cstr, [])}; arg2] ->
+        intcomp
+    | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_int
                      or same_base_type arg1.exp_type Predef.type_char ->
         intcomp
     | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_float ->
@@ -204,13 +242,14 @@ let transl_prim prim args =
   with Not_found ->
   try
     let p = Hashtbl.find primitives_table prim.prim_name in
+    (* Try strength reduction based on the type of the argument *)
     begin match (p, args) with
-        (Psetfield(n, _), [arg1; arg2]) ->
-          Psetfield(n, maybe_pointer arg2)
-      | (Psafesetvectitem _, [arg1; arg2; arg3]) ->
-          Psafesetvectitem(maybe_pointer arg3)
-      | (Psetvectitem _, [arg1; arg2; arg3]) ->
-          Psetvectitem(maybe_pointer arg3)
+        (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
+      | (Parraylength Pgenarray, [arg])   -> Parraylength(array_kind arg)
+      | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1)
+      | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1)
+      | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1)
+      | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1)
       | _ -> p
     end
   with Not_found ->
@@ -237,7 +276,13 @@ let check_recursive_lambda id lam =
 
 exception Not_constant
 
-let extract_constant = function Lconst sc -> sc | _ -> raise Not_constant
+let extract_constant = function
+    Lconst sc -> sc
+  | _ -> raise Not_constant
+
+let extract_float = function
+    Const_base(Const_float f) -> f
+  | _ -> fatal_error "Translcore.extract_float"
 
 (* To find reasonable names for let-bound and lambda-bound idents *)
 
@@ -309,28 +354,39 @@ let rec transl_exp env e =
       | Cstr_exception path ->
           Lprim(Pmakeblock 0, transl_path path :: ll)
       end
-  | Texp_record lbl_expr_list ->
-      let lv = Array.new (List.length lbl_expr_list) Lstaticfail in
+  | Texp_record ((lbl1, _) :: _ as lbl_expr_list) ->
+      let lv = Array.new (Array.length lbl1.lbl_all) Lstaticfail in
       List.iter
         (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp env expr)
         lbl_expr_list;
       let ll = Array.to_list lv in
-      if List.for_all (fun (lbl, expr) -> lbl.lbl_mut = Immutable)
-                      lbl_expr_list
-      then begin
-        try
-          Lconst(Const_block(0, List.map extract_constant ll))
-        with Not_constant ->
-          Lprim(Pmakeblock 0, ll)
-      end else
-        Lprim(Pmakeblock 0, ll)
+      begin try
+        List.iter
+          (fun (lbl, expr) -> if lbl.lbl_mut = Mutable then raise Not_constant)
+          lbl_expr_list;
+        let cl = List.map extract_constant ll in
+        match lbl1.lbl_repres with
+          Record_regular -> Lconst(Const_block(0, cl))
+        | Record_float -> Lconst(Const_float_array(List.map extract_float cl))
+      with Not_constant ->
+        match lbl1.lbl_repres with
+          Record_regular -> Lprim(Pmakeblock 0, ll)
+        | Record_float -> Lprim(Pmakearray Pfloatarray, ll)
+      end
   | Texp_field(arg, lbl) ->
-      Lprim(Pfield lbl.lbl_pos, [transl_exp env arg])
+      let access =
+        match lbl.lbl_repres with
+          Record_regular -> Pfield lbl.lbl_pos
+        | Record_float -> Pfloatfield lbl.lbl_pos in
+      Lprim(access, [transl_exp env arg])
   | Texp_setfield(arg, lbl, newval) ->
-      Lprim(Psetfield(lbl.lbl_pos, maybe_pointer newval),
-            [transl_exp env arg; transl_exp env newval])
+      let access =
+        match lbl.lbl_repres with
+          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
+        | Record_float -> Psetfloatfield lbl.lbl_pos in
+      Lprim(access, [transl_exp env arg; transl_exp env newval])
   | Texp_array expr_list ->
-      Lprim(Pmakeblock 0, transl_list env expr_list)
+      Lprim(Pmakearray(array_kind e), transl_list env expr_list)
   | Texp_ifthenelse(cond, ifso, Some ifnot) ->
       Lifthenelse(transl_exp env cond, transl_exp env ifso,
                                        transl_exp env ifnot)
@@ -345,6 +401,8 @@ let rec transl_exp env e =
            transl_exp env body)
   | Texp_when(cond, body) ->
       Lifthenelse(transl_exp env cond, transl_exp env body, Lstaticfail)
+  | _ ->
+      fatal_error "Translcore.transl"
 
 and transl_list env = function
     [] -> []
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 34c2023dd9..9291129623 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -9,7 +9,7 @@ val transl_exp: compilenv -> expression -> lambda
 val transl_let:
         compilenv -> rec_flag -> (pattern * expression) list ->
           compilenv * (lambda -> lambda)
-val transl_primitive: primitive_description option -> lambda
+val transl_primitive: Primitive.description option -> lambda
 val transl_exception: Ident.t -> exception_declaration -> lambda
 
 type error =