Merge record label descriptions and definition into a single array

bytecomp/translcore.ml

@@ -864,10 +864,8 @@ and transl_exp0 e =
             Lprim(Pmakeblock(0, Immutable, None),
                   [Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
       end
-  | Texp_record (label_definitions, label_descriptions, repr, opt_init_expr) ->
-      transl_record e.exp_loc e.exp_env
-        label_descriptions repr label_definitions
-        opt_init_expr
+  | Texp_record (fields, repr, opt_init_expr) ->
+      transl_record e.exp_loc e.exp_env fields repr opt_init_expr
   | Texp_field(arg, _, lbl) ->
       let access =
         match lbl.lbl_repres with
@@ -1260,8 +1258,8 @@ and transl_setinstvar loc self var expr =
   in
   Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc)
 
-and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
-  let size = Array.length all_labels in
+and transl_record loc env fields repres opt_init_expr =
+  let size = Array.length fields in
   (* Determine if there are "enough" fields (only relevant if this is a
      functional-style record update *)
   let no_init = match opt_init_expr with None -> true | _ -> false in
@@ -1272,7 +1270,7 @@ and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
     let init_id = Ident.create "init" in
     let lv =
       Array.mapi
-        (fun i definition ->
+        (fun i (definition, _) ->
            match definition with
            | Kept typ ->
                let field_kind = value_kind env typ in
@@ -1285,11 +1283,11 @@ and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
            | Overridden (_lid, expr) ->
                let field_kind = value_kind expr.exp_env expr.exp_type in
                transl_exp expr, field_kind)
-        lbl_definitions
+        fields
     in
     let ll, shape = List.split (Array.to_list lv) in
     let mut =
-      if Array.exists (fun lbl -> lbl.lbl_mut = Mutable) all_labels
+      if Array.exists (fun (_, lbl) -> lbl.lbl_mut = Mutable) fields
       then Mutable
       else Immutable in
     let lam =
@@ -1313,7 +1311,8 @@ and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
             Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
         | Record_extension ->
             let path =
-              match all_labels.(0).lbl_res.desc with
+              let (_, label) = fields.(0) in
+              match label.lbl_res.desc with
               | Tconstr(p, _, _) -> p
               | _ -> assert false
             in
@@ -1331,7 +1330,7 @@ and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
     (* If you change anything here, you will likely have to change
        [check_recursive_recordwith] in this file. *)
     let copy_id = Ident.create "newrecord" in
-    let update_field definition lbl cont =
+    let update_field (definition, lbl) cont =
       match definition with
       | Kept _type -> cont
       | Overridden (_lid, expr) ->
@@ -1351,8 +1350,7 @@ and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
     | Some init_expr ->
         Llet(Strict, Pgenval, copy_id,
              Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc),
-             Misc.Stdlib.Array.fold_right2 update_field
-               lbl_definitions all_labels (Lvar copy_id))
+             Array.fold_right update_field fields (Lvar copy_id))
     end
   end
 

typing/printtyped.ml

@@ -323,7 +323,7 @@ and expression i ppf x =
   | Texp_variant (l, eo) ->
       line i ppf "Texp_variant \"%s\"\n" l;
       option i expression ppf eo;
-  | Texp_record (l, _, _, eo) ->
+  | Texp_record (l, _, eo) ->
       line i ppf "Texp_record\n";
       array i record_field ppf l;
       option i expression ppf eo;
@@ -838,10 +838,10 @@ and string_x_expression i ppf (s, _, e) =
   expression (i+1) ppf e;
 
 and record_field i ppf = function
-  | Overridden (li, e) ->
+  | Overridden (li, e), _ ->
       line i ppf "%a\n" fmt_longident li;
       expression (i+1) ppf e;
-  | Kept _ ->
+  | Kept _, _ ->
       line i ppf "<kept>"
 
 and label_x_expression i ppf (l, e) =

typing/tast_mapper.ml

@@ -255,15 +255,16 @@ let expr sub x =
         Texp_construct (lid, cd, List.map (sub.expr sub) args)
     | Texp_variant (l, expo) ->
         Texp_variant (l, opt (sub.expr sub) expo)
-    | Texp_record (fields, labels, repr, expo) ->
+    | Texp_record (fields, repr, expo) ->
         let fields = Array.map (function
-            | Kept t -> Kept t
-            | Overridden (lid, exp) ->
-                Overridden (lid, sub.expr sub exp))
+            | Kept t, label -> Kept t, label
+            | Overridden (lid, exp), label ->
+                Overridden (lid, sub.expr sub exp),
+                label)
             fields
         in
         Texp_record (
-          fields, labels, repr,
+          fields, repr,
           opt (sub.expr sub) expo
         )
     | Texp_field (exp, lid, ld) ->

typing/typecore.ml

@@ -1573,14 +1573,14 @@ let rec is_nonexpansive exp =
   | Texp_construct( _, _, el) ->
       List.for_all is_nonexpansive el
   | Texp_variant(_, arg) -> is_nonexpansive_opt arg
-  | Texp_record (lbl_definitions, lbl_descriptions, _, opt_init_exp) ->
-      Misc.Stdlib.Array.for_all2
-        (fun definition lbl ->
+  | Texp_record (fields, _, opt_init_exp) ->
+      Array.for_all
+        (fun (definition, lbl) ->
            match definition with
            | Overridden (_, exp) ->
                lbl.lbl_mut = Immutable && is_nonexpansive exp
            | Kept _ -> true)
-        lbl_definitions lbl_descriptions
+        fields
       && is_nonexpansive_opt opt_init_exp
   | Texp_field(exp, _, _) -> is_nonexpansive exp
   | Texp_array [] -> true
@@ -2339,8 +2339,12 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
         lbl_all, lbl_repres
       in
+      let fields =
+        Array.map2 (fun def descr -> def, descr)
+          label_definitions label_descriptions
+      in
       re {
-        exp_desc = Texp_record(label_definitions, label_descriptions,
+        exp_desc = Texp_record(fields,
                                record_representation, opt_exp);
         exp_loc = loc; exp_extra = [];
         exp_type = instance env ty_expected;

typing/typedtree.ml

@@ -86,7 +86,7 @@ and expression_desc =
       Longident.t loc * constructor_description * expression list
   | Texp_variant of label * expression option
   | Texp_record of
-      record_label_definition array * Types.label_description array *
+      ( record_label_definition * Types.label_description ) array *
       Types.record_representation * expression option
   | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of

typing/typedtree.mli

@@ -187,13 +187,19 @@ and expression_desc =
          *)
   | Texp_variant of label * expression option
   | Texp_record of
-      record_label_definition array * Types.label_description array *
+      ( record_label_definition * Types.label_description ) array *
       Types.record_representation * expression option
         (** { l1=P1; ...; ln=Pn }           (None)
             { E0 with l1=P1; ...; ln=Pn }   (Some E0)
 
             Invariant: n > 0
-         *)
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              ([| Kept t1, l1; Override P2, l2 |], representation,
+               Some E0)
+        *)
   | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
       expression * Longident.t loc * label_description * expression

typing/typedtreeIter.ml

@@ -295,10 +295,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
                 None -> ()
               | Some exp -> iter_expression exp
             end
-        | Texp_record (fields, _, _, expo) ->
+        | Texp_record (fields, _, expo) ->
             Array.iter (function
-                | Kept _ -> ()
-                | Overridden (_, exp) -> iter_expression exp)
+                | Kept _, _ -> ()
+                | Overridden (_, exp), _ -> iter_expression exp)
               fields;
             begin match expo with
                 None -> ()

typing/typedtreeMap.ml

@@ -306,19 +306,20 @@ module MakeMap(Map : MapArgument) = struct
             | Some exp -> Some (map_expression exp)
           in
           Texp_variant (label, expo)
-        | Texp_record (fields, labels, repr, expo) ->
+        | Texp_record (fields, repr, expo) ->
           let fields =
             Array.map (function
-                | Kept t -> Kept t
-                | Overridden (lid, exp) ->
-                    Overridden (lid, map_expression exp))
+                | Kept t, label -> Kept t, label
+                | Overridden (lid, exp), label ->
+                    Overridden (lid, map_expression exp),
+                    label)
               fields
           in
           let expo = match expo with
               None -> expo
             | Some exp -> Some (map_expression exp)
           in
-          Texp_record (fields, labels, repr, expo)
+          Texp_record (fields, repr, expo)
         | Texp_field (exp, lid, label) ->
           Texp_field (map_expression exp, lid, label)
         | Texp_setfield (exp1, lid, label, exp2) ->

typing/untypeast.ml

@@ -410,10 +410,10 @@ let expression sub exp =
           ))
     | Texp_variant (label, expo) ->
         Pexp_variant (label, map_opt (sub.expr sub) expo)
-    | Texp_record (fields, _labels, _repr, expo) ->
+    | Texp_record (fields, _repr, expo) ->
         let list = Array.fold_left (fun l -> function
-            | Kept _ -> l
-            | Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            | Kept _, _ -> l
+            | Overridden (lid, exp), _ -> (lid, sub.expr sub exp) :: l)
             [] fields
         in
         Pexp_record (list, map_opt (sub.expr sub) expo)