Fix ocamlobjinfo for flambda (ocaml#809)

* Fix printing of export_info MPR#7294

The printing function now requires a list of root symbols

* Add an option to hide some information in objinfo

Author: chambart

asmcomp/export_info.ml

@@ -224,7 +224,7 @@ let nest_eid_map map =
   in
   Export_id.Map.fold add_map map Compilation_unit.Map.empty
 
-let print_approx ppf (t : t) =
+let print_approx ppf ((t,root_symbols) : t * Symbol.t list) =
   let values = t.values in
   let fprintf = Format.fprintf in
   let printed = ref Export_id.Set.empty in
@@ -329,6 +329,7 @@ let print_approx ppf (t : t) =
       print_recorded_symbols ();
     end
   in
+  List.iter (fun s -> Queue.push s symbols_to_print) root_symbols;
   fprintf ppf "@[<hov 2>Globals:@ ";
   fprintf ppf "@]@ @[<hov 2>Symbols:@ ";
   print_recorded_symbols ();
@@ -345,10 +346,13 @@ let print_offsets ppf (t : t) =
         Var_within_closure.print vid off) t.offset_fv;
   Format.fprintf ppf "@]@ "
 
-let print_all ppf (t : t) =
+let print_functions ppf (t : t) =
+  Set_of_closures_id.Map.print Flambda.print_function_declarations ppf
+    t.sets_of_closures
+
+let print_all ppf ((t, root_symbols) : t * Symbol.t list) =
   let fprintf = Format.fprintf in
   fprintf ppf "approxs@ %a@.@."
-    print_approx t;
+    print_approx (t, root_symbols);
   fprintf ppf "functions@ %a@.@."
-    (Set_of_closures_id.Map.print Flambda.print_function_declarations)
-    t.sets_of_closures
+    print_functions t

asmcomp/export_info.mli

@@ -143,6 +143,7 @@ val nest_eid_map
 
 (**/**)
 (* Debug printing functions. *)
-val print_approx : Format.formatter -> t -> unit
+val print_approx : Format.formatter -> t * Symbol.t list -> unit
+val print_functions : Format.formatter -> t -> unit
 val print_offsets : Format.formatter -> t -> unit
-val print_all : Format.formatter -> t -> unit
+val print_all : Format.formatter -> t * Symbol.t list -> unit

asmcomp/import_approx.ml

@@ -55,6 +55,7 @@ let import_set_of_closures =
   in
   let aux set_of_closures_id =
     let ex_info = Compilenv.approx_env () in
+    let root_symbol = Compilenv.current_unit_symbol () in
     let function_declarations =
       try
         Set_of_closures_id.Map.find set_of_closures_id
@@ -63,7 +64,7 @@ let import_set_of_closures =
         Misc.fatal_errorf "[functions] does not map set of closures ID %a. \
             ex_info = %a"
           Set_of_closures_id.print set_of_closures_id
-          Export_info.print_all ex_info
+          Export_info.print_all (ex_info, [root_symbol])
     in
     import_function_declarations function_declarations
   in

tools/objinfo.ml

@@ -23,6 +23,10 @@ open Misc
 open Config
 open Cmo_format
 
+(* Command line option to prevent printing approximation and function code *)
+let no_approx = ref false
+let no_code = ref false
+
 let input_stringlist ic len =
   let get_string_list sect len =
     let rec fold s e acc =
@@ -122,16 +126,33 @@ let print_cmx_infos (ui, crc) =
     ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
   begin match ui.ui_export_info with
   | Clambda approx ->
-    printf "Approximation:\n";
-    Format.fprintf Format.std_formatter "  %a@." Printclambda.approx approx
+    if not !no_approx then begin
+      printf "Clambda approximation:\n";
+      Format.fprintf Format.std_formatter "  %a@." Printclambda.approx approx
+    end else
+      Format.printf "Clambda unit@.";
   | Flambda export ->
-    printf "Flambda export information:\n";
-    let cu =
-      Compilation_unit.create (Ident.create_persistent ui.ui_name)
-        (Linkage_name.create "__dummy__")
-    in
-    Compilation_unit.set_current cu;
-    Format.printf " %a\n" Export_info.print_all export
+    if not !no_approx || not !no_code then
+      printf "Flambda export information:\n"
+    else
+      printf "Flambda unit\n";
+    if not !no_approx then begin
+      let cu =
+        Compilation_unit.create (Ident.create_persistent ui.ui_name)
+          (Linkage_name.create "__dummy__")
+      in
+      Compilation_unit.set_current cu;
+      let root_symbols =
+        List.map (fun s ->
+            Symbol.unsafe_create cu (Linkage_name.create ("caml"^s)))
+          ui.ui_defines
+      in
+      Format.printf "approximations@ %a@.@."
+        Export_info.print_approx (export, root_symbols)
+    end;
+    if not !no_code then
+      Format.printf "functions@ %a@.@."
+        Export_info.print_functions export
   end;
   let pr_funs _ fns =
     List.iter (fun arity -> printf " %d" arity) fns in
@@ -291,7 +312,10 @@ let dump_obj filename =
     end
   end
 
-let arg_list = []
+let arg_list = [
+  "-no-approx", Arg.Set no_approx, " Do not print module approximation information";
+  "-no-code", Arg.Set no_code, " Do not print code from exported flambda functions"
+]
 let arg_usage =
    Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0)