instrument debug info when setfield(floatfield)

Author: Hongbo Zhang

asmcomp/closure.ml

@@ -149,9 +149,9 @@ let prim_size prim args =
   | Psetglobal id -> 1
   | Pmakeblock(tag, _, mut) -> 5 + List.length args
   | Pfield _ -> 1
-  | Psetfield(f, isptr) -> if isptr then 4 else 1
+  | Psetfield(f, isptr,_) -> if isptr then 4 else 1
   | Pfloatfield _ -> 1
-  | Psetfloatfield f -> 1
+  | Psetfloatfield _ -> 1
   | Pduprecord _ -> 10 + List.length args
   | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
   | Praise _ -> 4
@@ -924,11 +924,11 @@ let rec close fenv cenv = function
       let (ulam, approx) = close fenv cenv lam in
       check_constant_result lam (Uprim(field, [ulam], Debuginfo.none))
                             (field_approx n approx)
-  | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
+  | Lprim(Psetfield(n, _,dbg_info), [Lprim(Pgetglobal id, []); lam]) ->
       let (ulam, approx) = close fenv cenv lam in
       if approx <> Value_unknown then
         (!global_approx).(n) <- approx;
-      (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none),
+      (Uprim(Psetfield(n, false, dbg_info), [getglobal id; ulam], Debuginfo.none),
        Value_unknown)
   | Lprim(Praise k, [Levent(arg, ev)]) ->
       let (ulam, approx) = close fenv cenv arg in

asmcomp/cmmgen.ml

@@ -1660,13 +1660,13 @@ and transl_prim_1 p arg dbg =
 and transl_prim_2 p arg1 arg2 dbg =
   match p with
   (* Heap operations *)
-    Psetfield(n, ptr) ->
+    Psetfield(n, ptr, _) ->
       if ptr then
         return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
                         [field_address (transl arg1) n; transl arg2]))
       else
         return_unit(set_field (transl arg1) n (transl arg2))
-  | Psetfloatfield n ->
+  | Psetfloatfield (n,_) ->
       let ptr = transl arg1 in
       return_unit(
         Cop(Cstore Double_u,

bytecomp/bytegen.ml

@@ -302,9 +302,9 @@ let comp_primitive p args =
   | Pintcomp cmp -> Kintcomp cmp
   | Pmakeblock(tag, _, mut) -> Kmakeblock(List.length args, tag)
   | Pfield (n, _) -> Kgetfield n
-  | Psetfield(n, ptr) -> Ksetfield n
+  | Psetfield(n, ptr, _) -> Ksetfield n
   | Pfloatfield (n,_) -> Kgetfloatfield n
-  | Psetfloatfield n -> Ksetfloatfield n
+  | Psetfloatfield (n,_) -> Ksetfloatfield n
   | Pduprecord _ -> Kccall("caml_obj_dup", 1)
   | Pccall p -> Kccall(p.prim_name, p.prim_arity)
   | Pnegint -> Knegint

bytecomp/lambda.ml

@@ -44,6 +44,10 @@ type field_dbg_info =
   | Fld_record of string
   | Fld_module of string 
 
+type set_field_dbg_info = 
+  | Fld_set_na
+  | Fld_record_set of string 
+
 type primitive =
   | Pidentity
   | Pbytes_to_string
@@ -61,9 +65,9 @@ type primitive =
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag
   | Pfield of int * field_dbg_info
-  | Psetfield of int * bool
+  | Psetfield of int * bool * set_field_dbg_info
   | Pfloatfield of int * field_dbg_info
-  | Psetfloatfield of int
+  | Psetfloatfield of int * set_field_dbg_info
   | Pduprecord of Types.record_representation * int
   (* Force lazy values *)
   | Plazyforce

bytecomp/lambda.mli

@@ -46,6 +46,10 @@ type field_dbg_info =
   | Fld_record of string
   | Fld_module of string 
 
+type set_field_dbg_info = 
+  | Fld_set_na
+  | Fld_record_set of string 
+
 type pointer_info = 
   | NullConstructor of string
   | NullVariant of string 
@@ -70,9 +74,10 @@ type primitive =
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag
   | Pfield of int * field_dbg_info
-  | Psetfield of int * bool (* could have field info at least for record *)
+  | Psetfield of int * bool * set_field_dbg_info
+  (* could have field info at least for record *)
   | Pfloatfield of int * field_dbg_info
-  | Psetfloatfield of int
+  | Psetfloatfield of int * set_field_dbg_info
   | Pduprecord of Types.record_representation * int
   (* Force lazy values *)
   | Plazyforce

bytecomp/printlambda.ml

@@ -110,11 +110,11 @@ let primitive ppf = function
   | Pmakeblock(tag, _, Immutable) -> fprintf ppf "makeblock %i" tag
   | Pmakeblock(tag, _, Mutable) -> fprintf ppf "makemutable %i" tag
   | Pfield (n,_) -> fprintf ppf "field %i" n
-  | Psetfield(n, ptr) ->
+  | Psetfield(n, ptr, _) ->
       let instr = if ptr then "setfield_ptr " else "setfield_imm " in
       fprintf ppf "%s%i" instr n
   | Pfloatfield (n,_) -> fprintf ppf "floatfield %i" n
-  | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n
+  | Psetfloatfield (n,_) -> fprintf ppf "setfloatfield %i" n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
   | Plazyforce -> fprintf ppf "force"
   | Pccall p -> fprintf ppf "%s" p.prim_name
@@ -372,7 +372,7 @@ let lambda use_env env ppf v  =
   | Lprim(Pfield (n,_), [ Lprim(Pgetglobal id,[])]) when use_env ->
       fprintf ppf "%s.%s/%d" id.name (get_string (id,n) env) n
 
-  | Lprim(Psetfield (n,_), [ Lprim(Pgetglobal id,[]) ;  e ]) when use_env  ->
+  | Lprim(Psetfield (n,_,_), [ Lprim(Pgetglobal id,[]) ;  e ]) when use_env  ->
       fprintf ppf "@[<2>(%s.%s/%d <- %a)@]" id.name (get_string (id,n) env) n
         lam e
   | Lprim(prim, largs) ->

bytecomp/simplif.ml

@@ -37,7 +37,7 @@ let rec eliminate_ref id = function
               eliminate_ref id e2)
   | Lprim(Pfield (0, _), [Lvar v]) when Ident.same v id ->
       Lvar id
-  | Lprim(Psetfield(0, _), [Lvar v; e]) when Ident.same v id ->
+  | Lprim(Psetfield(0, _, _), [Lvar v; e]) when Ident.same v id ->
       Lassign(id, eliminate_ref id e)
   | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id ->
       Lassign(id, Lprim(Poffsetint delta, [Lvar id]))

bytecomp/translclass.ml

@@ -777,7 +777,7 @@ let transl_class ids cl_id pub_meths cl vflag =
                 [Lvar tables; Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable), inh_keys)]),
          lam)
   and lset cached i lam =
-    Lprim(Psetfield(i, true), [Lvar cached; lam])
+    Lprim(Psetfield(i, true, Fld_set_na), [Lvar cached; lam])
   in
   let ldirect () =
     ltable cla

bytecomp/translcore.ml

@@ -148,7 +148,7 @@ let primitives_table = create_hashtable 57 [
   "%ignore", Pignore;
   "%field0", Pfield (0, Fld_na);
   "%field1", Pfield (1, Fld_na);
-  "%setfield0", Psetfield(0, true);
+  "%setfield0", Psetfield(0, true, Fld_set_na);
   "%makeblock", Pmakeblock(0, Lambda.default_tag_info, Immutable);
   "%makemutable", Pmakeblock(0,Lambda.default_tag_info,  Mutable);
   "%raise", Praise Raise_regular;
@@ -386,7 +386,7 @@ let transl_prim loc prim args =
     let p = find_primitive loc 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)
+        (Psetfield(n, _, dbg_info), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2, dbg_info)
       | (Parraylength Pgenarray, [arg])   -> Parraylength(array_kind arg)
       | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1)
       | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1)
@@ -798,8 +798,8 @@ and transl_exp0 e =
   | Texp_setfield(arg, _, lbl, newval) ->
       let access =
         match lbl.lbl_repres with
-          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
-        | Record_float -> Psetfloatfield lbl.lbl_pos in
+          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval, Fld_record_set lbl.lbl_name)
+        | Record_float -> Psetfloatfield (lbl.lbl_pos, Fld_record_set lbl.lbl_name) in
       Lprim(access, [transl_exp arg; transl_exp newval])
   | Texp_array expr_list ->
       let kind = array_kind e in
@@ -1136,8 +1136,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
     let update_field (_, lbl, expr) cont =
       let upd =
         match lbl.lbl_repres with
-          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
-        | Record_float -> Psetfloatfield lbl.lbl_pos in
+          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr, Fld_record_set lbl.lbl_name)
+        | Record_float -> Psetfloatfield (lbl.lbl_pos, Fld_record_set lbl.lbl_name) in
       Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
     begin match opt_init_expr with
       None -> assert false

bytecomp/translmod.ml

@@ -702,7 +702,7 @@ let transl_store_structure glob map prims str =
     try
       let (pos, cc) = Ident.find_same id map in
       let init_val = apply_coercion Alias cc (Lvar id) in
-      Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val])
+      Lprim(Psetfield(pos, false, Fld_set_na), [Lprim(Pgetglobal glob, []); init_val])
     with Not_found ->
       fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
 
@@ -724,7 +724,7 @@ let transl_store_structure glob map prims str =
     List.fold_right (add_ident may_coerce) idlist subst
 
   and store_primitive (pos, prim) cont =
-    Lsequence(Lprim(Psetfield(pos, false),
+    Lsequence(Lprim(Psetfield(pos, false, Fld_set_na),
                     [Lprim(Pgetglobal glob, []);
                      transl_primitive Location.none prim]),
               cont)
@@ -938,7 +938,7 @@ let transl_store_package component_names target_name coercion =
       (List.length component_names,
        make_sequence
          (fun pos id ->
-           Lprim(Psetfield(pos, false),
+           Lprim(Psetfield(pos, false, Fld_set_na),
                  [Lprim(Pgetglobal target_name, []);
                   get_component id]))
          0 component_names)
@@ -951,7 +951,7 @@ let transl_store_package component_names target_name coercion =
        Llet (Strict, blk, apply_coercion Strict coercion components,
              make_sequence
                (fun pos id ->
-                 Lprim(Psetfield(pos, false),
+                 Lprim(Psetfield(pos, false, Fld_set_na),
                        [Lprim(Pgetglobal target_name, []);
                         Lprim(Pfield (pos, Fld_na), [Lvar blk])]))
                0 pos_cc_list))