Add indirection for field/block meta data information

Author: bobzhang

.depend

@@ -143,11 +143,11 @@ parsing/pprintast.cmx : parsing/parsetree.cmi utils/misc.cmx \
     parsing/ast_helper.cmx parsing/pprintast.cmi
 parsing/pprintast.cmi : parsing/parsetree.cmi
 parsing/printast.cmo : parsing/parsetree.cmi utils/misc.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
-    parsing/printast.cmi
+    parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \
+    parsing/asttypes.cmi parsing/printast.cmi
 parsing/printast.cmx : parsing/parsetree.cmi utils/misc.cmx \
-    parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
-    parsing/printast.cmi
+    parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \
+    parsing/asttypes.cmi parsing/printast.cmi
 parsing/printast.cmi : parsing/parsetree.cmi
 parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi
 parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi
@@ -317,12 +317,12 @@ typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
     typing/env.cmi parsing/asttypes.cmi
 typing/printtyped.cmo : typing/types.cmi typing/typedtree.cmi \
     parsing/printast.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/ident.cmi parsing/asttypes.cmi \
-    typing/printtyped.cmi
+    parsing/location.cmi typing/ident.cmi utils/clflags.cmi \
+    parsing/asttypes.cmi typing/printtyped.cmi
 typing/printtyped.cmx : typing/types.cmx typing/typedtree.cmx \
     parsing/printast.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
-    parsing/location.cmx typing/ident.cmx parsing/asttypes.cmi \
-    typing/printtyped.cmi
+    parsing/location.cmx typing/ident.cmx utils/clflags.cmx \
+    parsing/asttypes.cmi typing/printtyped.cmi
 typing/printtyped.cmi : typing/typedtree.cmi
 typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi utils/misc.cmi \
     parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
@@ -574,8 +574,9 @@ bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
 bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
     parsing/asttypes.cmi bytecomp/lambda.cmi
-bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
-    parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
+bytecomp/lambda.cmi : typing/types.cmi typing/typedtree.cmi \
+    typing/primitive.cmi typing/path.cmi parsing/location.cmi \
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 bytecomp/matching.cmo : typing/types.cmi typing/typeopt.cmi \
     typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \

bytecomp/lambda.ml

@@ -52,19 +52,38 @@ type tag_info =
   | Blk_lazy_general
   | Blk_lazy_forward
   | Blk_class (* Ocaml style class*) 
+
 let default_tag_info : tag_info = Blk_na ""
+let blk_record = ref (fun fields -> 
+  let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
+  Blk_record all_labels_info
+  )
+
+let blk_record_ext =  ref (fun fields -> 
+    let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
+    Blk_record_ext all_labels_info
+  )
+
+let blk_record_inlined = ref (fun fields name num_nonconsts -> 
+  let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
+  Blk_record_inlined (all_labels_info, name, num_nonconsts)
+) 
 
 let ref_tag_info : tag_info = Blk_record [| "contents" |]
 
 type field_dbg_info = 
   | Fld_na
-  | Fld_record of string
+  | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
   | Fld_module of string     
   | Fld_record_inline of string   
   | Fld_record_extension of string 
   | Fld_tuple  
 
-let ref_field_info : field_dbg_info = Fld_record "contents"    
+let fld_record = ref (fun (lbl : Types.label_description) ->
+  Fld_record {name = lbl.lbl_name; mutable_flag = Mutable})
+
+let ref_field_info : field_dbg_info = 
+  Fld_record { name = "contents"; mutable_flag = Mutable}
 
 type set_field_dbg_info = 
     | Fld_set_na
@@ -73,6 +92,8 @@ type set_field_dbg_info =
     | Fld_record_extension_set of string
 
 let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents"    
+let fld_record_set = ref ( fun (lbl : Types.label_description) ->
+  Fld_record_set lbl.lbl_name  )
 
 type immediate_or_pointer =
   | Immediate

bytecomp/lambda.mli

@@ -62,18 +62,43 @@ type tag_info =
   | Blk_lazy_general  
   | Blk_lazy_forward
   | Blk_class (* ocaml style class *)
+
+val blk_record : 
+  ( 
+    (Types.label_description* Typedtree.record_label_definition) array ->
+    tag_info
+  ) ref
+
+val blk_record_ext :
+  ( 
+    (Types.label_description* Typedtree.record_label_definition) array ->
+    tag_info
+  ) ref
+
+val blk_record_inlined :   
+  ( 
+    (Types.label_description* Typedtree.record_label_definition) array ->
+    string ->
+    int ->
+    tag_info
+  ) ref
+
 val default_tag_info : tag_info
 
 val ref_tag_info : tag_info
 
 type field_dbg_info = 
   | Fld_na
-  | Fld_record of string
+  | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag}
   | Fld_module of string     
   | Fld_record_inline of string 
   | Fld_record_extension of string 
   | Fld_tuple
 
+val fld_record :
+  (Types.label_description -> 
+  field_dbg_info) ref
+
 val ref_field_info : field_dbg_info   
 
 type set_field_dbg_info = 
@@ -84,6 +109,10 @@ type set_field_dbg_info =
 
 val ref_field_set_info : set_field_dbg_info    
 
+val fld_record_set : 
+  (Types.label_description ->
+  set_field_dbg_info) ref
+
 type immediate_or_pointer =
   | Immediate
   | Pointer

bytecomp/matching.ml

@@ -1655,11 +1655,11 @@ let make_record_matching loc all_labels def = function
           let access =
             match lbl.lbl_repres with
             | Record_regular  -> 
-              Lprim (Pfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [arg], loc) 
+              Lprim (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [arg], loc) 
             | Record_inlined _ ->
               Lprim (Pfield (lbl.lbl_pos, Fld_record_inline lbl.lbl_name), [arg], loc)
             | Record_unboxed _ -> arg
-            | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [arg], loc)
+            | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, !Lambda.fld_record lbl), [arg], loc)
             | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Fld_record_extension lbl.lbl_name), [arg], loc) 
           in
           let str =

bytecomp/printlambda.ml

@@ -142,7 +142,7 @@ let primitive ppf = function
       fprintf ppf "makeblock %i%a" tag block_shape shape
   | Pmakeblock(tag, _, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag block_shape shape
-  | Pfield (n, (Fld_module s | Fld_record s)) -> fprintf ppf "field:%s/%i" s n      
+  | Pfield (n, (Fld_module s | Fld_record {name=s})) -> fprintf ppf "field:%s/%i" s n      
   | Pfield (n,_) -> fprintf ppf "field %i" n
   | Pfield_computed -> fprintf ppf "field_computed"
   | Psetfield(n, ptr, init, _) ->

bytecomp/translcore.ml

@@ -1034,23 +1034,23 @@ and transl_exp0 e =
       let targ = transl_exp arg in
       begin match lbl.lbl_repres with
           Record_regular -> 
-          Lprim (Pfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [targ], e.exp_loc) 
+          Lprim (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [targ], e.exp_loc) 
         | Record_inlined _ ->
           Lprim (Pfield (lbl.lbl_pos, Fld_record_inline lbl.lbl_name), [targ], e.exp_loc)
         | Record_unboxed _ -> targ
-        | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, Fld_record lbl.lbl_name), [targ], e.exp_loc)
+        | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, !Lambda.fld_record lbl), [targ], e.exp_loc)
         | Record_extension ->
           Lprim (Pfield (lbl.lbl_pos + 1, Fld_record_extension lbl.lbl_name), [targ], e.exp_loc) 
       end
   | Texp_setfield(arg, _, lbl, newval) ->
       let access =
         match lbl.lbl_repres with
           Record_regular -> 
-          Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment, Fld_record_set lbl.lbl_name)
+          Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment, !Lambda.fld_record_set lbl)
         | Record_inlined _ -> 
           Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment, Fld_record_inline_set lbl.lbl_name)
         | Record_unboxed _ -> assert false
-        | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment, Fld_record_set lbl.lbl_name)
+        | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment, !Lambda.fld_record_set lbl)
         | Record_extension -> 
           Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment, Fld_record_extension_set lbl.lbl_name)
       in
@@ -1440,11 +1440,11 @@ and transl_record loc env fields repres opt_init_expr =
                let field_kind = value_kind env typ in
                let access =
                  match repres with
-                   Record_regular ->   Pfield (i, Fld_record lbl.lbl_name) 
+                   Record_regular ->   Pfield (i, !Lambda.fld_record lbl) 
                  | Record_inlined _ -> Pfield (i, Fld_record_inline lbl.lbl_name) 
                  | Record_unboxed _ -> assert false
                  | Record_extension -> Pfield (i + 1, Fld_record_extension lbl.lbl_name) 
-                 | Record_float -> Pfloatfield (i, Fld_record lbl.lbl_name) in
+                 | Record_float -> Pfloatfield (i, !Lambda.fld_record lbl) in
                Lprim(access, [Lvar init_id], loc), field_kind
            | Overridden (_lid, expr) ->
                let field_kind = value_kind expr.exp_env expr.exp_type in
@@ -1456,30 +1456,29 @@ and transl_record loc env fields repres opt_init_expr =
       if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
       then Mutable
       else Immutable in
-    let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in    
     let lam =
       try
         if mut = Mutable then raise Not_constant;
         let cl = List.map extract_constant ll in
         match repres with
-        | Record_regular -> Lconst(Const_block(0, Lambda.Blk_record all_labels_info, cl))
-        | Record_inlined {tag;name;num_nonconsts} -> Lconst(Const_block(tag, Lambda.Blk_record_inlined (all_labels_info,name,num_nonconsts), cl))
+        | Record_regular -> Lconst(Const_block(0, !Lambda.blk_record fields, cl))
+        | Record_inlined {tag;name;num_nonconsts} -> Lconst(Const_block(tag, !Lambda.blk_record_inlined fields name num_nonconsts, cl))
         | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
         | Record_float ->
-            if !Clflags.bs_only then Lconst(Const_block(0, Lambda.Blk_record all_labels_info, cl))
+            if !Clflags.bs_only then Lconst(Const_block(0, !Lambda.blk_record fields, cl))
             else
             Lconst(Const_float_array(List.map extract_float cl))
         | Record_extension ->
             raise Not_constant
       with Not_constant ->
         match repres with
           Record_regular ->
-            Lprim(Pmakeblock(0, Lambda.Blk_record all_labels_info, mut, Some shape), ll, loc)
+            Lprim(Pmakeblock(0, !Lambda.blk_record fields, mut, Some shape), ll, loc)
         | Record_inlined {tag;name; num_nonconsts} ->
-            Lprim(Pmakeblock(tag, Lambda.Blk_record_inlined (all_labels_info, name, num_nonconsts), mut, Some shape), ll, loc)
+            Lprim(Pmakeblock(tag, !Lambda.blk_record_inlined fields name num_nonconsts, mut, Some shape), ll, loc)
         | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
         | Record_float ->
-            if !Clflags.bs_only then Lprim(Pmakeblock(0, Lambda.Blk_record all_labels_info, mut, Some shape), ll, loc)
+            if !Clflags.bs_only then Lprim(Pmakeblock(0, !Lambda.blk_record fields, mut, Some shape), ll, loc)
             else
             Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
         | Record_extension ->
@@ -1490,7 +1489,7 @@ and transl_record loc env fields repres opt_init_expr =
               | _ -> assert false
             in
             let slot = transl_extension_path env path in
-            Lprim(Pmakeblock(0, Lambda.Blk_record_ext all_labels_info, mut, Some (Pgenval :: shape)), slot :: ll, loc) 
+            Lprim(Pmakeblock(0, !Lambda.blk_record_ext fields, mut, Some (Pgenval :: shape)), slot :: ll, loc) 
     in
     begin match opt_init_expr with
       None -> lam
@@ -1508,11 +1507,11 @@ and transl_record loc env fields repres opt_init_expr =
           let upd =
             match repres with
               Record_regular -> 
-              Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment, Fld_record_set lbl.lbl_name)
+              Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment, !Lambda.fld_record_set lbl)
             | Record_inlined _ -> 
                 Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment, Fld_record_inline_set lbl.lbl_name)
             | Record_unboxed _ -> assert false
-            | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment, Fld_record_set lbl.lbl_name)
+            | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment, !Lambda.fld_record_set lbl)
             | Record_extension -> 
                 Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment, Fld_record_extension_set lbl.lbl_name)
           in

parsing/builtin_attributes.ml

@@ -105,6 +105,11 @@ let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
       Location.deprecated ~def ~use loc
         (Printf.sprintf "mutating field %s" (cat s txt))
 
+let check_bs_attributes_inclusion = 
+  ref (fun _attrs1 _attrs2 _s -> 
+      None
+    )  
+
 let rec deprecated_of_sig = function
   | {psig_desc = Psig_attribute a} :: tl ->
       begin match deprecated_of_attrs [a] with

parsing/builtin_attributes.mli

@@ -42,6 +42,10 @@ val check_deprecated_mutable_inclusion:
   def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
   Parsetree.attributes -> string -> unit
 
+val check_bs_attributes_inclusion:
+  (Parsetree.attributes ->
+  Parsetree.attributes -> string -> (string*string) option ) ref
+
 val error_of_extension: Parsetree.extension -> Location.error
 
 val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit

typing/includecore.ml

@@ -247,6 +247,12 @@ and compare_records ~loc env params1 params2 n
           loc
           ld1.ld_attributes ld2.ld_attributes
           (Ident.name ld1.ld_id);
+        let field_mismatch = !Builtin_attributes.check_bs_attributes_inclusion  
+          ld1.ld_attributes ld2.ld_attributes
+          (Ident.name ld1.ld_id) in 
+        match field_mismatch with
+        | Some (a,b) -> [Field_names (n,a,b)]
+        | None ->
         if Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2)
         then (* add arguments to the parameters, cf. PR#7378 *)
           compare_records ~loc env