instrument field information

Author: Hongbo Zhang

asmcomp/closure.ml

@@ -39,7 +39,7 @@ let rec split_list n l =
 let rec build_closure_env env_param pos = function
     [] -> Tbl.empty
   | id :: rem ->
-      Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none))
+      Tbl.add id (Uprim(Pfield (pos, Fld_na), [Uvar env_param], Debuginfo.none))
               (build_closure_env env_param (pos+1) rem)
 
 (* Auxiliary for accessing globals.  We change the name of the global
@@ -148,9 +148,9 @@ let prim_size prim args =
   | Pgetglobal id -> 1
   | Psetglobal id -> 1
   | Pmakeblock(tag, _, mut) -> 5 + List.length args
-  | Pfield f -> 1
+  | Pfield _ -> 1
   | Psetfield(f, isptr) -> if isptr then 4 else 1
-  | Pfloatfield f -> 1
+  | Pfloatfield _ -> 1
   | Psetfloatfield f -> 1
   | Pduprecord _ -> 10 + List.length args
   | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
@@ -469,10 +469,10 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
         (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
       end
   (* Field access *)
-  | Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ]
+  | Pfield (n,_), _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ]
     when n < List.length l ->
       make_const (List.nth l n)
-  | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx]
+  | Pfield (n,_), [ Uprim(Pmakeblock _, ul, _) ], [approx]
     when n < List.length ul ->
       (List.nth ul n, field_approx n approx)
   (* Strings *)
@@ -715,7 +715,7 @@ let check_constant_result lam ulam approx =
           let glb =
             Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none)
           in
-          Uprim(Pfield i, [glb], Debuginfo.none), approx
+          Uprim(Pfield (i, Fld_na), [glb], Debuginfo.none), approx
       end
   | _ -> (ulam, approx)
 
@@ -920,9 +920,9 @@ let rec close fenv cenv = function
       check_constant_result lam
                             (getglobal id)
                             (Compilenv.global_approx id)
-  | Lprim(Pfield n, [lam]) ->
+  | Lprim((Pfield (n, _) as field), [lam]) ->
       let (ulam, approx) = close fenv cenv lam in
-      check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none))
+      check_constant_result lam (Uprim(field, [ulam], Debuginfo.none))
                             (field_approx n approx)
   | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
       let (ulam, approx) = close fenv cenv lam in

asmcomp/cmmgen.ml

@@ -1560,9 +1560,9 @@ and transl_prim_1 p arg dbg =
   | Pignore ->
       return_unit(remove_unit (transl arg))
   (* Heap operations *)
-  | Pfield n ->
+  | Pfield (n,_) ->
       get_field (transl arg) n
-  | Pfloatfield n ->
+  | Pfloatfield (n,_) ->
       let ptr = transl arg in
       box_float(
         Cop(Cload Double_u,

boot/ocamlc

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

boot/ocamldep

@@ -33,11 +33,17 @@ type tag_info =
   | Tuple
   | Array
   | Variant of string 
-  | Record 
+  | Record of string array (* when its empty means we dont get such information *)
+  | Module of string list option
   | NA
 
 let default_tag_info : tag_info = NA
 
+type field_dbg_info = 
+  | Fld_na
+  | Fld_record of string
+  | Fld_module of string 
+
 type primitive =
   | Pidentity
   | Pbytes_to_string
@@ -54,9 +60,9 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag
-  | Pfield of int
+  | Pfield of int * field_dbg_info
   | Psetfield of int * bool
-  | Pfloatfield of int
+  | Pfloatfield of int * field_dbg_info
   | Psetfloatfield of int
   | Pduprecord of Types.record_representation * int
   (* Force lazy values *)
@@ -485,7 +491,7 @@ let rec transl_normal_path = function
     Pident id ->
       if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
   | Pdot(p, s, pos) ->
-      Lprim(Pfield pos, [transl_normal_path p])
+      Lprim(Pfield (pos, Fld_na (* TODO *)), [transl_normal_path p])
   | Papply(p1, p2) ->
       fatal_error "Lambda.transl_path"
 

boot/ocamllex

@@ -35,11 +35,17 @@ type tag_info =
   | Tuple
   | Array
   | Variant of string 
-  | Record 
+  | Record of string array
+  | Module of string list option
   | NA
 
 val default_tag_info : tag_info
 
+type field_dbg_info = 
+  | Fld_na
+  | Fld_record of string
+  | Fld_module of string 
+
 type pointer_info = 
   | NullConstructor of string
   | NullVariant of string 
@@ -63,9 +69,9 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag
-  | Pfield of int
-  | Psetfield of int * bool
-  | Pfloatfield of int
+  | Pfield of int * field_dbg_info
+  | Psetfield of int * bool (* could have field info at least for record *)
+  | Pfloatfield of int * field_dbg_info
   | Psetfloatfield of int
   | Pduprecord of Types.record_representation * int
   (* Force lazy values *)

bytecomp/bytegen.ml

@@ -1288,7 +1288,7 @@ 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)
+    else (Lprim(Pfield (pos, Fld_na (* TODO*) ), [arg]), binding_kind) :: make_args (pos + 1)
   in make_args first_pos
 
 let get_key_constr = function
@@ -1403,7 +1403,7 @@ let make_variant_matching_nonconst p lab def ctx = function
       let def = make_default (matcher_variant_nonconst lab) def
       and ctx = filter_ctx p ctx in
       {pm=
-        {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl;
+        {cases = []; args = (Lprim(Pfield (1, Fld_na (* TODO*)), [arg]), Alias) :: argl;
           default=def} ;
         ctx=ctx ;
         pat = normalize_pat p}
@@ -1490,7 +1490,8 @@ let get_mod_field modname field =
       with Not_found ->
         fatal_error ("Primitive "^modname^"."^field^" not found.")
       in
-      Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
+      Lprim(Pfield (p, Fld_na (* TODO - then we dont need query any more*)), 
+            [Lprim(Pgetglobal mod_ident, [])])
     with Not_found -> fatal_error ("Module "^modname^" unavailable.")
   )
 
@@ -1519,7 +1520,7 @@ let inline_lazy_force_cond arg loc =
               (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
               Lprim(Pintcomp Ceq,
                     [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]),
-              Lprim(Pfield 0, [varg]),
+              Lprim(Pfield (0, Fld_na (* TODO: lazy *)), [varg]),
               Lifthenelse(
                 (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
                 Lprim(Pintcomp Ceq,
@@ -1540,7 +1541,7 @@ let inline_lazy_force_switch arg loc =
              { sw_numconsts = 0; sw_consts = [];
                sw_numblocks = 256;  (* PR#6033 - tag ranges from 0 to 255 *)
                sw_blocks =
-                 [ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
+                 [ (Obj.forward_tag, Lprim(Pfield (0, Fld_na (* TODO: lazy *)), [varg]));
                    (Obj.lazy_tag,
                     Lapply(force_fun, [varg], loc)) ];
                sw_failaction = Some varg } ))))
@@ -1589,7 +1590,7 @@ let make_tuple_matching arity def = function
       let rec make_args pos =
         if pos >= arity
         then argl
-        else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
+        else (Lprim(Pfield (pos, Fld_na (* TODO: tuple*)) , [arg]), Alias) :: make_args (pos + 1) in
       {cases = []; args = make_args 0 ;
         default=make_default (matcher_tuple arity) def}
 
@@ -1628,8 +1629,8 @@ let make_record_matching all_labels def = function
           let lbl = all_labels.(pos) in
           let access =
             match lbl.lbl_repres with
-              Record_regular -> Pfield lbl.lbl_pos
-            | Record_float -> Pfloatfield lbl.lbl_pos in
+              Record_regular -> Pfield (lbl.lbl_pos, Fld_record lbl.lbl_name)
+            | Record_float -> Pfloatfield (lbl.lbl_pos, Fld_record lbl.lbl_name) in
           let str =
             match lbl.lbl_mut with
               Immutable -> Alias
@@ -2404,7 +2405,7 @@ let combine_constructor arg ex_pat cstr partial ctx def
                 nonconsts
                 default
             in
-              Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests)
+              Llet(Alias, tag, Lprim(Pfield (0, Fld_na), [arg]), tests)
       in
         List.fold_right
           (fun (path, act) rem ->
@@ -2470,7 +2471,7 @@ let call_switcher_variant_constant fail arg int_lambda_list =
 
 let call_switcher_variant_constr fail arg int_lambda_list =
   let v = Ident.create "variant" in
-  Llet(Alias, v, Lprim(Pfield 0, [arg]),
+  Llet(Alias, v, Lprim(Pfield (0, Fld_na), [arg]),
        call_switcher
          fail (Lvar v) min_int max_int int_lambda_list)
 

bytecomp/lambda.ml

@@ -109,11 +109,11 @@ let primitive ppf = function
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
   | Pmakeblock(tag, _, Immutable) -> fprintf ppf "makeblock %i" tag
   | Pmakeblock(tag, _, Mutable) -> fprintf ppf "makemutable %i" tag
-  | Pfield n -> fprintf ppf "field %i" n
+  | Pfield (n,_) -> fprintf ppf "field %i" n
   | 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
+  | Pfloatfield (n,_) -> fprintf ppf "floatfield %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"
@@ -369,7 +369,7 @@ let lambda use_env env ppf v  =
       fprintf ppf
         "@[<2>(let@ (@[<hv 1>%a@]" bindings (List.rev args);
       fprintf ppf ")@ %a)@]"  lam body
-  | Lprim(Pfield n, [ Lprim(Pgetglobal id,[])]) when use_env ->
+  | 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  ->