From cee1d9697f5858428904e622211eb807f9cc437d Mon Sep 17 00:00:00 2001
From: Mehdi Dogguy <mehdi@debian.org>
Date: Wed, 21 Apr 2010 19:38:02 +0200
Subject: [PATCH] Make objinfo read all kind of objects

Now, objinfo can read cmi, cmo, cma, cmx, cmxa, cmxs and bytecode
binaries and prints relevant information using the same format.
dumpapprox is not needed anymore.

This patch also fixes #4701.
---
 tools/Makefile.shared |   37 +++++--
 tools/dumpapprox.ml   |   97 -----------------
 tools/natdynlink.ml   |   31 ++++++
 tools/objinfo.ml      |  278 ++++++++++++++++++++++++++++++++++++++-----------
 tools/objinfo_stubs.c |   47 ++++++++
 5 files changed, 323 insertions(+), 167 deletions(-)
 delete mode 100644 tools/dumpapprox.ml
 create mode 100644 tools/natdynlink.ml
 create mode 100644 tools/objinfo_stubs.c

diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 477ba73..5151d3a 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -225,21 +225,42 @@ clean::
 
 beforedepend:: opnames.ml
 
-# Dump .cmx files
+# Dump compilation units and bytecode binaries
 
-dumpapprox: dumpapprox.cmo
-	$(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo
+../asmcomp/debuginfo.cmo: ../asmcomp/debuginfo.cmi
+../asmcomp/clambda.cmo: ../asmcomp/debuginfo.cmo ../asmcomp/clambda.cmi
+../asmcomp/compilenv.cmo: ../asmcomp/compilenv.cmi
 
-clean::
-	rm -f dumpapprox
+OBJDEPS=../asmcomp/clambda.cmo ../typing/ident.cmo ../utils/tbl.cmo \
+	../utils/misc.cmo ../typing/path.cmo ../typing/types.cmo \
+	../typing/btype.cmo ../utils/config.cmo ../typing/predef.cmo \
+	../typing/datarepr.cmo ../utils/consistbl.cmo \
+	../typing/subst.cmo ../utils/clflags.cmo ../typing/env.cmo \
+	../asmcomp/compilenv.cmo ../bytecomp/bytesections.cmo\
+	natdynlink.cmo objinfo.cmo
+
+objinfo.cmo: objinfo.ml
+	$(CAMLC) $(LINKFLAGS) -c $(COMPFLAGS) $<
+
+OBJSTUBS=objinfo_stubs
+
+$(OBJSTUBS).o: $(OBJSTUBS).c
+	$(CAMLC) -ccopt "-o $@ $(CFLAGS)" -c $^
 
-# Print imported interfaces for .cmo files
+dll$(OBJSTUBS).so: ocamlmklib $(OBJSTUBS).o
+	../boot/ocamlrun ./ocamlmklib -o $(OBJSTUBS) \
+		$(OBJSTUBS).o -ldl -lbfd
 
-objinfo: objinfo.cmo
-	$(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo
+objinfo: dll$(OBJSTUBS).so $(OBJDEPS)
+	$(CAMLC) $(LINKFLAGS) -dllib dll$(OBJSTUBS).so \
+		-cclib -l$(OBJSTUBS) -o objinfo \
+		$(OBJSTUBS).o $(OBJDEPS)
 
 clean::
 	rm -f objinfo
+	rm -f objinfo.cm*
+	rm -f $(OBJSTUBS).o
+	rm -f dll$(OBJSTUBS).so
 
 # Scan object files for required primitives
 
diff --git a/tools/dumpapprox.ml b/tools/dumpapprox.ml
deleted file mode 100644
index 4270842..0000000
--- a/tools/dumpapprox.ml
+++ /dev/null
@@ -1,97 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Dump a .cmx file *)
-
-open Config
-open Format
-open Clambda
-open Compilenv
-
-let print_digest ppf d =
-  for i = 0 to String.length d - 1 do
-    print_string(Printf.sprintf "%02x" (Char.code d.[i]))
-  done
-
-let rec print_approx ppf = function
-    Value_closure(fundesc, approx) ->
-      printf "@[<2>function %s@ arity %i" fundesc.fun_label fundesc.fun_arity;
-      if fundesc.fun_closed then begin
-        printf "@ (closed)"
-      end;
-      if fundesc.fun_inline <> None then begin
-        printf "@ (inline)"
-      end;
-      printf "@ -> @ %a@]" print_approx approx
-  | Value_tuple approx ->
-      let tuple ppf approx =
-        for i = 0 to Array.length approx - 1 do
-          if i > 0 then printf ";@ ";
-          printf "%i: %a" i print_approx approx.(i)
-        done in
-      printf "@[<hov 1>(%a)@]" tuple approx
-  | Value_unknown ->
-      print_string "_"
-  | Value_integer n ->
-      print_int n
-  | Value_constptr n ->
-      print_int n; print_string "p"
-
-let print_name_crc (name, crc) =
-  printf "@ %s (%a)" name print_digest crc
-
-let print_infos (ui, crc) =
-  printf "Name: %s@." ui.ui_name;
-  printf "CRC of implementation: %a@." print_digest crc;
-  printf "@[<hov 2>Globals defined:";
-  List.iter (fun s -> printf "@ %s" s) ui.ui_defines;
-  printf "@]@.";
-  let pr_imports ppf imps = List.iter print_name_crc imps in
-  printf "@[<v 2>Interfaces imported:%a@]@." pr_imports ui.ui_imports_cmi;
-  printf "@[<v 2>Implementations imported:%a@]@." pr_imports ui.ui_imports_cmx;
-  printf "@[<v 2>Approximation:@ %a@]@." print_approx ui.ui_approx;
-  let pr_funs ppf fns =
-    List.iter (fun arity -> printf "@ %i" arity) fns in
-  printf "@[<2>Currying functions:%a@]@." pr_funs ui.ui_curry_fun;
-  printf "@[<2>Apply functions:%a@]@." pr_funs ui.ui_apply_fun
-
-let print_unit_info filename =
-  let ic = open_in_bin filename in
-  try
-    let buffer = String.create (String.length cmx_magic_number) in
-    really_input ic buffer 0 (String.length cmx_magic_number);
-    if buffer = cmx_magic_number then begin
-      let ui = (input_value ic : unit_infos) in
-      let crc = Digest.input ic in
-      close_in ic;
-      print_infos (ui, crc)
-    end else if buffer = cmxa_magic_number then begin
-      let li = (input_value ic : library_infos) in
-      close_in ic;
-      List.iter print_infos li.lib_units
-    end else begin
-      close_in ic;
-      prerr_endline "Wrong magic number";
-      exit 2
-    end
-  with End_of_file | Failure _ ->
-    close_in ic;
-    prerr_endline "Error reading file";
-    exit 2
-
-let main () =
-  print_unit_info Sys.argv.(1);
-  exit 0
-
-let _ = main ()
diff --git a/tools/natdynlink.ml b/tools/natdynlink.ml
new file mode 100644
index 0000000..f562f2b
--- /dev/null
+++ b/tools/natdynlink.ml
@@ -0,0 +1,31 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../../LICENSE.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Copied from other places to avoid dependencies *)
+
+type dynunit = {
+  name: string;
+  crc: Digest.t;
+  imports_cmi: (string * Digest.t) list;
+  imports_cmx: (string * Digest.t) list;
+  defines: string list;
+}
+
+type dynheader = {
+  magic: string;
+  units: dynunit list;
+}
+
+let dyn_magic_number = "Caml2007D001"
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index 943f83f..cb3b18d 100644
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -12,84 +12,238 @@
 
 (* $Id$ *)
 
-(* Dump a compilation unit description *)
+(* Dump a compilation unit description or a bytecode file *)
 
+open Format
 open Config
 open Cmo_format
+open Clambda
+open Natdynlink
+
+exception Not_an_object of string
+
+external get_cmxs_info : string -> int = "caml_get_cmxs_offset"
+
+let sprint_digest d =
+  let len = String.length d in
+  let rec sp string i d =
+    if i < len
+    then
+      let str = sprintf "%s%02x" string (Char.code d.[i]) in
+      sp str (i + 1) d
+    else string
+  in
+  sp "" 0 d
 
 let print_digest d =
-  for i = 0 to String.length d - 1 do
-    Printf.printf "%02x" (Char.code d.[i])
-  done
+  print_string (sprint_digest d)
 
-let print_info cu =
-  print_string "  Unit name: "; print_string cu.cu_name; print_newline();
-  print_string "  Interfaces imported:"; print_newline();
-  List.iter
-    (fun (name, digest) ->
-      print_string "\t"; print_digest digest; print_string "\t";
-      print_string name; print_newline())
-    cu.cu_imports;
-  print_string "  Uses unsafe features: ";
-  begin match cu.cu_primitives with
-    [] -> print_string "no"; print_newline()
-  | l  -> print_string "YES"; print_newline();
-          print_string "  Primitives declared in this module:";
-          print_newline();
-          List.iter
-            (fun name -> print_string "\t"; print_string name; print_newline())
-            l
-  end
+let input_stringlist ic len =
+  let get_string_list sect len =
+    let rec fold s e acc =
+      if e != len then
+        if sect.[e] = '\000' then
+          fold (e+1) (e+1) (String.sub sect s (e-s) :: acc)
+        else fold s (e+1) acc
+      else acc
+    in fold 0 0 []
+  in
+  let sect = String.create len in
+  let _ = really_input ic sect 0 len in
+  get_string_list sect len
+
+let print_name_crc (name, crc) =
+  printf "\n\t%s\t%s%!" (sprint_digest crc) name
+
+let print_prim name =
+  printf "\n\t%s%!" name
+
+let print_primitives prims =
+  printf "\nUses unsafe features: ";
+  match prims with
+    | [] -> printf "no@."
+    | l  ->
+        printf "YES@.";
+        printf "Primitives declared in this module:@?";
+        List.iter print_prim l;
+        print_newline ()
+
+let print_cmo_infos cu =
+  printf "Unit name: %s@." cu.cu_name;
+  print_string "Interfaces imported:";
+  List.iter print_name_crc cu.cu_imports;
+  print_primitives cu.cu_primitives
+
+let rec print_approx_infos ppf = function
+    Value_closure(fundesc, approx) ->
+      printf "@[<2>function %s@ arity %i"
+        fundesc.fun_label fundesc.fun_arity;
+      if fundesc.fun_closed then begin
+        printf "@ (closed)"
+      end;
+      if fundesc.fun_inline <> None then begin
+        printf "@ (inline)"
+      end;
+      printf "@ -> @ %a@]" print_approx_infos approx
+  | Value_tuple approx ->
+      let tuple ppf approx =
+        for i = 0 to Array.length approx - 1 do
+          if i > 0 then printf ";@ ";
+          printf "%i: %a" i print_approx_infos approx.(i)
+        done in
+      printf "@[<hov 1>(%a)@]" tuple approx
+  | Value_unknown ->
+      print_string "_"
+  | Value_integer n ->
+      print_int n
+  | Value_constptr n ->
+      print_int n; print_string "p"
 
-let print_spaced_string s = print_char ' '; print_string s
+let print_spaced_string s =
+  printf " %s" s
 
-let print_library_info lib =
-  print_string "  Force custom: ";
-  print_string (if lib.lib_custom then "YES" else "no");
-  print_newline();
-  print_string "  Extra C object files:";
+let print_cma_infos (lib : Cmo_format.library) =
+  printf "Force custom: %s@." (if lib.lib_custom then "YES" else "no");
+  printf "Extra C object files: %!";
   (* PR#4949: print in linking order *)
-  List.iter print_spaced_string (List.rev lib.lib_ccobjs); print_newline();
-  print_string "  Extra C options:";
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  print_string "\nExtra C options:";
   List.iter print_spaced_string lib.lib_ccopts; print_newline();
-  List.iter print_info lib.lib_units
+  List.iter print_cmo_infos lib.lib_units;
+  print_string "  Extra dynamically-loaded libraries:";
+  List.iter print_spaced_string lib.lib_dllibs; print_newline()
 
-let print_intf_info name sign comps crcs =
-  print_string "  Module name: "; print_string name; print_newline();
-  print_string "  Interfaces imported:"; print_newline();
+let print_cmi_infos name sign comps crcs =
+  printf "Module name: %s\n%!" name;
+  printf "Interfaces imported:%!";
+  List.iter print_name_crc crcs;
+  print_newline ()
+
+let print_general_infos name crc defines cmi cmx =
+  let pr_imports _ imps = List.iter print_name_crc imps in
+  printf "Name: %s@." name;
+  printf "CRC of implementation: %s@." (Digest.to_hex crc);
+  printf "Globals defined: @?";
+  List.iter print_endline defines;
+  printf "Interfaces imported: %a@." pr_imports cmi;
+  printf "Implementations imported: %a@." pr_imports cmx
+
+open Compilenv
+
+let print_cmx_infos (ui, crc) =
+  print_general_infos
+    ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
+  printf "Approximation: %a@." print_approx_infos ui.ui_approx;
+  let pr_funs _ fns =
+    List.iter (fun arity -> printf " %i%!" arity) fns in
+  printf "Currying functions:%a@." pr_funs ui.ui_curry_fun;
+  printf "Apply functions:%a@." pr_funs ui.ui_apply_fun
+
+let p_title title = printf "%s:%!" title
+
+let p_section title = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print_name_crc l
+
+let p_list title print = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print l
+
+let dump_byte ic =
+  Bytesections.read_toc ic;
+  let toc = Bytesections.toc () in
+  let toc = List.sort Pervasives.compare toc in
   List.iter
-    (fun (name, digest) ->
-      print_string "\t"; print_digest digest; print_string "\t";
-      print_string name; print_newline())
-    crcs
+    (fun (section, _) ->
+       try
+         let len = Bytesections.seek_section ic section in
+         if len > 0 then match section with
+           | "CRCS" ->
+               p_section
+                 "Imported Units"
+                 (input_value ic : (string * Digest.t) list)
+           | "DLLS" ->
+               p_list
+                 "Used Dlls"
+                 print_prim
+                 (input_stringlist ic len)
+           | "DLPT" ->
+               p_list
+                 "Additional Dll paths"
+                 print_prim
+                 (input_stringlist ic len)
+           | "PRIM" ->
+               print_primitives (input_stringlist ic len)
+           | _ -> ()
+       with _ -> ()
+    )
+    toc
 
 let dump_obj filename =
-  print_string "File "; print_string filename; print_newline();
   let ic = open_in_bin filename in
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
-  if buffer = cmo_magic_number then begin
-    let cu_pos = input_binary_int ic in
-    seek_in ic cu_pos;
-    let cu = (input_value ic : compilation_unit) in
-    close_in ic;
-    print_info cu
-  end else
-  if buffer = cma_magic_number then begin
-    let toc_pos = input_binary_int ic in
-    seek_in ic toc_pos;
-    let toc = (input_value ic : library) in
-    close_in ic;
-    print_library_info toc
-  end else
-  if buffer = cmi_magic_number then begin
-    let (name, sign, comps) = input_value ic in
-    let crcs = input_value ic in
+  try
+    let len_magic_number = String.length cmo_magic_number in
+    let magic_number = String.create len_magic_number in
+    really_input ic magic_number 0 len_magic_number;
+    if magic_number = cmo_magic_number then
+      let cu_pos = input_binary_int ic in
+      seek_in ic cu_pos;
+      let cu = (input_value ic : compilation_unit) in
+      close_in ic;
+      print_cmo_infos cu
+    else if magic_number = cma_magic_number then
+      let toc_pos = input_binary_int ic in
+      seek_in ic toc_pos;
+      let toc = (input_value ic : library) in
+      close_in ic;
+      print_cma_infos toc
+    else if magic_number = cmi_magic_number then
+      let (name, sign, comps) = input_value ic in
+      let crcs = input_value ic in
+      close_in ic;
+      print_cmi_infos name sign comps crcs
+    else if magic_number = cmx_magic_number then
+      let ui = (input_value ic : Compilenv.unit_infos) in
+      let crc = Digest.input ic in
+      close_in ic;
+      print_cmx_infos (ui, crc)
+    else if magic_number = cmxa_magic_number then
+      let li = (input_value ic : library_infos) in
+      close_in ic;
+      List.iter print_cmx_infos li.lib_units
+    else
+      let pos_trailer = in_channel_length ic - len_magic_number in
+      let _ = seek_in ic pos_trailer in
+      let _ = really_input ic magic_number 0 len_magic_number in
+      if magic_number = Config.exec_magic_number then begin
+        dump_byte ic;
+        close_in ic
+      end
+      else
+        let offset = get_cmxs_info filename in
+        let _ = seek_in ic offset in
+        let header = (input_value ic : Natdynlink.dynheader) in
+        if offset <> -1 && header.magic = Natdynlink.dyn_magic_number
+        then begin
+          List.iter
+            (fun ui ->
+               print_general_infos
+                 ui.name
+                 ui.crc
+                 ui.defines
+                 ui.imports_cmi
+                 ui.imports_cmx)
+            header.units;
+          close_in ic
+        end
+        else raise Not_found
+  with _ ->
     close_in ic;
-    print_intf_info name sign comps crcs
-  end else begin
-    prerr_endline "Not an object file"; exit 2
-  end
+    raise (Not_an_object filename)
 
 let main() =
   for i = 1 to Array.length Sys.argv - 1 do
diff --git a/tools/objinfo_stubs.c b/tools/objinfo_stubs.c
new file mode 100644
index 0000000..7bfd0a6
--- /dev/null
+++ b/tools/objinfo_stubs.c
@@ -0,0 +1,47 @@
+
+#include "../byterun/mlvalues.h"
+#include "../byterun/alloc.h"
+#include <string.h>
+#include <bfd.h>
+
+static unsigned long int get_cmxs_offset (char *file)
+{
+  unsigned int result = -1;
+
+  bfd *fd;
+  fd = bfd_openr(file, "default");
+  if (!fd) return -1;
+
+  if (bfd_check_format (fd, bfd_object)) {
+    asection *sec;
+    sec = bfd_get_section_by_name(fd, ".data");
+
+    if (sec) {
+      unsigned long long int offset = sec->filepos;
+      long st_size = bfd_get_dynamic_symtab_upper_bound (fd);
+
+      if (st_size > 0) {
+        asymbol **symbol_table;
+        symbol_table = malloc(st_size);
+
+        long sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table);
+        long i;
+        for (i = 0; i < sym_count; i++) {
+          if (!strcmp(symbol_table[i]->name, "caml_plugin_header")) {
+            result = offset + symbol_table[i]->value;
+          }
+        }
+
+        free(symbol_table);
+      }
+    }
+  }
+
+  bfd_close(fd);
+  return result;
+}
+
+CAMLprim value caml_get_cmxs_offset(value file)
+{
+  return Val_long(get_cmxs_offset(String_val(file)));
+}
-- 
1.7.0

From 2476e411485c5033899a0288de8a6589b4b14116 Mon Sep 17 00:00:00 2001
From: Mehdi Dogguy <mehdi@debian.org>
Date: Wed, 21 Apr 2010 19:38:02 +0200
Subject: [PATCH] Enhanced objinfo (updated)

---
 tools/Makefile.shared |   38 +++++--
 tools/dumpapprox.ml   |   97 ----------------
 tools/natdynlink.ml   |   31 +++++
 tools/objinfo.ml      |  291 ++++++++++++++++++++++++++++++++++++++-----------
 tools/objinfo_stubs.c |   56 ++++++++++
 5 files changed, 343 insertions(+), 170 deletions(-)
 delete mode 100644 tools/dumpapprox.ml
 create mode 100644 tools/natdynlink.ml
 create mode 100644 tools/objinfo_stubs.c

diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 477ba73..68c7624 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -225,21 +225,43 @@ clean::
 
 beforedepend:: opnames.ml
 
-# Dump .cmx files
+# Dump compilation units and bytecode binaries
 
-dumpapprox: dumpapprox.cmo
-	$(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo
+../asmcomp/debuginfo.cmo: ../asmcomp/debuginfo.cmi
+../asmcomp/clambda.cmo: ../asmcomp/debuginfo.cmo ../asmcomp/clambda.cmi
+../asmcomp/compilenv.cmo: ../asmcomp/compilenv.cmi
 
-clean::
-	rm -f dumpapprox
+OBJDEPS=../asmcomp/clambda.cmo ../typing/ident.cmo ../utils/tbl.cmo \
+	../utils/misc.cmo ../typing/path.cmo ../typing/types.cmo \
+	../typing/btype.cmo ../utils/config.cmo ../typing/predef.cmo \
+	../typing/datarepr.cmo ../utils/consistbl.cmo \
+	../typing/subst.cmo ../utils/clflags.cmo ../typing/env.cmo \
+	../asmcomp/compilenv.cmo ../bytecomp/bytesections.cmo\
+	natdynlink.cmo objinfo.cmo
+
+objinfo.cmo: objinfo.ml
+	$(CAMLC) $(LINKFLAGS) -c $(COMPFLAGS) $<
+
+OBJSTUBS=objinfo_stubs
+
+$(OBJSTUBS).o: $(OBJSTUBS).c
+	$(CAMLC) -pp "$(CPP)" -ccopt "-o $@ $(CFLAGS)" -c $^
 
-# Print imported interfaces for .cmo files
+dll$(OBJSTUBS).so: ocamlmklib $(OBJSTUBS).o
+# LIBBFD_CFLAGS should contain "-ldl -lbfd" when HAS_LIBBFD is defined
+	../boot/ocamlrun ./ocamlmklib -o $(OBJSTUBS) \
+		$(OBJSTUBS).o $(LIBBFD_CFLAGS)
 
-objinfo: objinfo.cmo
-	$(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo
+objinfo: dll$(OBJSTUBS).so $(OBJDEPS)
+	$(CAMLC) $(LINKFLAGS) -dllib dll$(OBJSTUBS).so \
+		-cclib -l$(OBJSTUBS) -o objinfo \
+		$(OBJSTUBS).o $(OBJDEPS)
 
 clean::
 	rm -f objinfo
+	rm -f objinfo.cm*
+	rm -f $(OBJSTUBS).o
+	rm -f dll$(OBJSTUBS).so
 
 # Scan object files for required primitives
 
diff --git a/tools/dumpapprox.ml b/tools/dumpapprox.ml
deleted file mode 100644
index 4270842..0000000
--- a/tools/dumpapprox.ml
+++ /dev/null
@@ -1,97 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Dump a .cmx file *)
-
-open Config
-open Format
-open Clambda
-open Compilenv
-
-let print_digest ppf d =
-  for i = 0 to String.length d - 1 do
-    print_string(Printf.sprintf "%02x" (Char.code d.[i]))
-  done
-
-let rec print_approx ppf = function
-    Value_closure(fundesc, approx) ->
-      printf "@[<2>function %s@ arity %i" fundesc.fun_label fundesc.fun_arity;
-      if fundesc.fun_closed then begin
-        printf "@ (closed)"
-      end;
-      if fundesc.fun_inline <> None then begin
-        printf "@ (inline)"
-      end;
-      printf "@ -> @ %a@]" print_approx approx
-  | Value_tuple approx ->
-      let tuple ppf approx =
-        for i = 0 to Array.length approx - 1 do
-          if i > 0 then printf ";@ ";
-          printf "%i: %a" i print_approx approx.(i)
-        done in
-      printf "@[<hov 1>(%a)@]" tuple approx
-  | Value_unknown ->
-      print_string "_"
-  | Value_integer n ->
-      print_int n
-  | Value_constptr n ->
-      print_int n; print_string "p"
-
-let print_name_crc (name, crc) =
-  printf "@ %s (%a)" name print_digest crc
-
-let print_infos (ui, crc) =
-  printf "Name: %s@." ui.ui_name;
-  printf "CRC of implementation: %a@." print_digest crc;
-  printf "@[<hov 2>Globals defined:";
-  List.iter (fun s -> printf "@ %s" s) ui.ui_defines;
-  printf "@]@.";
-  let pr_imports ppf imps = List.iter print_name_crc imps in
-  printf "@[<v 2>Interfaces imported:%a@]@." pr_imports ui.ui_imports_cmi;
-  printf "@[<v 2>Implementations imported:%a@]@." pr_imports ui.ui_imports_cmx;
-  printf "@[<v 2>Approximation:@ %a@]@." print_approx ui.ui_approx;
-  let pr_funs ppf fns =
-    List.iter (fun arity -> printf "@ %i" arity) fns in
-  printf "@[<2>Currying functions:%a@]@." pr_funs ui.ui_curry_fun;
-  printf "@[<2>Apply functions:%a@]@." pr_funs ui.ui_apply_fun
-
-let print_unit_info filename =
-  let ic = open_in_bin filename in
-  try
-    let buffer = String.create (String.length cmx_magic_number) in
-    really_input ic buffer 0 (String.length cmx_magic_number);
-    if buffer = cmx_magic_number then begin
-      let ui = (input_value ic : unit_infos) in
-      let crc = Digest.input ic in
-      close_in ic;
-      print_infos (ui, crc)
-    end else if buffer = cmxa_magic_number then begin
-      let li = (input_value ic : library_infos) in
-      close_in ic;
-      List.iter print_infos li.lib_units
-    end else begin
-      close_in ic;
-      prerr_endline "Wrong magic number";
-      exit 2
-    end
-  with End_of_file | Failure _ ->
-    close_in ic;
-    prerr_endline "Error reading file";
-    exit 2
-
-let main () =
-  print_unit_info Sys.argv.(1);
-  exit 0
-
-let _ = main ()
diff --git a/tools/natdynlink.ml b/tools/natdynlink.ml
new file mode 100644
index 0000000..f562f2b
--- /dev/null
+++ b/tools/natdynlink.ml
@@ -0,0 +1,31 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../../LICENSE.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Copied from other places to avoid dependencies *)
+
+type dynunit = {
+  name: string;
+  crc: Digest.t;
+  imports_cmi: (string * Digest.t) list;
+  imports_cmx: (string * Digest.t) list;
+  defines: string list;
+}
+
+type dynheader = {
+  magic: string;
+  units: dynunit list;
+}
+
+let dyn_magic_number = "Caml2007D001"
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index 943f83f..4f4b45e 100644
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -12,84 +12,245 @@
 
 (* $Id$ *)
 
-(* Dump a compilation unit description *)
+(* Dump a compilation unit description or a bytecode file *)
 
+open Format
 open Config
 open Cmo_format
+open Clambda
+open Natdynlink
+
+external get_cmxs_info : string -> int = "caml_get_cmxs_offset"
+
+let sprint_digest d =
+  let len = String.length d in
+  let rec sp string i d =
+    if i < len
+    then
+      let str = sprintf "%s%02x" string (Char.code d.[i]) in
+      sp str (i + 1) d
+    else string
+  in
+  sp "" 0 d
 
 let print_digest d =
-  for i = 0 to String.length d - 1 do
-    Printf.printf "%02x" (Char.code d.[i])
-  done
+  print_string (sprint_digest d)
 
-let print_info cu =
-  print_string "  Unit name: "; print_string cu.cu_name; print_newline();
-  print_string "  Interfaces imported:"; print_newline();
-  List.iter
-    (fun (name, digest) ->
-      print_string "\t"; print_digest digest; print_string "\t";
-      print_string name; print_newline())
-    cu.cu_imports;
-  print_string "  Uses unsafe features: ";
-  begin match cu.cu_primitives with
-    [] -> print_string "no"; print_newline()
-  | l  -> print_string "YES"; print_newline();
-          print_string "  Primitives declared in this module:";
-          print_newline();
-          List.iter
-            (fun name -> print_string "\t"; print_string name; print_newline())
-            l
-  end
-
-let print_spaced_string s = print_char ' '; print_string s
-
-let print_library_info lib =
-  print_string "  Force custom: ";
-  print_string (if lib.lib_custom then "YES" else "no");
-  print_newline();
-  print_string "  Extra C object files:";
+let input_stringlist ic len =
+  let get_string_list sect len =
+    let rec fold s e acc =
+      if e != len then
+        if sect.[e] = '\000' then
+          fold (e+1) (e+1) (String.sub sect s (e-s) :: acc)
+        else fold s (e+1) acc
+      else acc
+    in fold 0 0 []
+  in
+  let sect = String.create len in
+  let _ = really_input ic sect 0 len in
+  get_string_list sect len
+
+let print_name_crc (name, crc) =
+  printf "\n\t%s\t%s%!" (sprint_digest crc) name
+
+let print_prim name =
+  printf "\n\t%s%!" name
+
+let print_primitives prims =
+  printf "\nUses unsafe features: ";
+  match prims with
+    | [] -> printf "no@."
+    | l  ->
+        printf "YES@.";
+        printf "Primitives declared in this module:@?";
+        List.iter print_prim l;
+        print_newline ()
+
+let print_cmo_infos cu =
+  printf "Unit name: %s@." cu.cu_name;
+  print_string "Interfaces imported:";
+  List.iter print_name_crc cu.cu_imports;
+  print_primitives cu.cu_primitives
+
+let rec print_approx_infos ppf = function
+    Value_closure(fundesc, approx) ->
+      printf "@[<2>function %s@ arity %i"
+        fundesc.fun_label fundesc.fun_arity;
+      if fundesc.fun_closed then begin
+        printf "@ (closed)"
+      end;
+      if fundesc.fun_inline <> None then begin
+        printf "@ (inline)"
+      end;
+      printf "@ -> @ %a@]" print_approx_infos approx
+  | Value_tuple approx ->
+      let tuple ppf approx =
+        for i = 0 to Array.length approx - 1 do
+          if i > 0 then printf ";@ ";
+          printf "%i: %a" i print_approx_infos approx.(i)
+        done in
+      printf "@[<hov 1>(%a)@]" tuple approx
+  | Value_unknown ->
+      print_string "_"
+  | Value_integer n ->
+      print_int n
+  | Value_constptr n ->
+      print_int n; print_string "p"
+
+let print_spaced_string s =
+  printf " %s" s
+
+let print_cma_infos (lib : Cmo_format.library) =
+  printf "Force custom: %s@." (if lib.lib_custom then "YES" else "no");
+  printf "Extra C object files: %!";
   (* PR#4949: print in linking order *)
-  List.iter print_spaced_string (List.rev lib.lib_ccobjs); print_newline();
-  print_string "  Extra C options:";
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  print_string "\nExtra C options:";
   List.iter print_spaced_string lib.lib_ccopts; print_newline();
-  List.iter print_info lib.lib_units
+  List.iter print_cmo_infos lib.lib_units;
+  print_string "  Extra dynamically-loaded libraries:";
+  List.iter print_spaced_string lib.lib_dllibs; print_newline()
+
+let print_cmi_infos name sign comps crcs =
+  printf "Module name: %s\n%!" name;
+  printf "Interfaces imported:%!";
+  List.iter print_name_crc crcs;
+  print_newline ()
+
+let print_general_infos name crc defines cmi cmx =
+  let pr_imports _ imps = List.iter print_name_crc imps in
+  printf "Name: %s@." name;
+  printf "CRC of implementation: %s@." (Digest.to_hex crc);
+  printf "Globals defined: @?";
+  List.iter print_endline defines;
+  printf "Interfaces imported: %a@." pr_imports cmi;
+  printf "Implementations imported: %a@." pr_imports cmx
+
+open Compilenv
+
+let print_cmx_infos (ui, crc) =
+  print_general_infos
+    ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
+  printf "Approximation: %a@." print_approx_infos ui.ui_approx;
+  let pr_funs _ fns =
+    List.iter (fun arity -> printf " %i%!" arity) fns in
+  printf "Currying functions:%a@." pr_funs ui.ui_curry_fun;
+  printf "Apply functions:%a@." pr_funs ui.ui_apply_fun
+
+let p_title title = printf "%s:%!" title
+
+let p_section title = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print_name_crc l
+
+let p_list title print = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print l
 
-let print_intf_info name sign comps crcs =
-  print_string "  Module name: "; print_string name; print_newline();
-  print_string "  Interfaces imported:"; print_newline();
+let dump_byte ic =
+  Bytesections.read_toc ic;
+  let toc = Bytesections.toc () in
+  let toc = List.sort Pervasives.compare toc in
   List.iter
-    (fun (name, digest) ->
-      print_string "\t"; print_digest digest; print_string "\t";
-      print_string name; print_newline())
-    crcs
+    (fun (section, _) ->
+       try
+         let len = Bytesections.seek_section ic section in
+         if len > 0 then match section with
+           | "CRCS" ->
+               p_section
+                 "Imported Units"
+                 (input_value ic : (string * Digest.t) list)
+           | "DLLS" ->
+               p_list
+                 "Used Dlls"
+                 print_prim
+                 (input_stringlist ic len)
+           | "DLPT" ->
+               p_list
+                 "Additional Dll paths"
+                 print_prim
+                 (input_stringlist ic len)
+           | "PRIM" ->
+               print_primitives (input_stringlist ic len)
+           | _ -> ()
+       with _ -> ()
+    )
+    toc
 
 let dump_obj filename =
-  print_string "File "; print_string filename; print_newline();
   let ic = open_in_bin filename in
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
-  if buffer = cmo_magic_number then begin
-    let cu_pos = input_binary_int ic in
-    seek_in ic cu_pos;
-    let cu = (input_value ic : compilation_unit) in
-    close_in ic;
-    print_info cu
-  end else
-  if buffer = cma_magic_number then begin
-    let toc_pos = input_binary_int ic in
-    seek_in ic toc_pos;
-    let toc = (input_value ic : library) in
-    close_in ic;
-    print_library_info toc
-  end else
-  if buffer = cmi_magic_number then begin
-    let (name, sign, comps) = input_value ic in
-    let crcs = input_value ic in
-    close_in ic;
-    print_intf_info name sign comps crcs
-  end else begin
-    prerr_endline "Not an object file"; exit 2
-  end
+  try
+    let len_magic_number = String.length cmo_magic_number in
+    let magic_number = String.create len_magic_number in
+    really_input ic magic_number 0 len_magic_number;
+    if magic_number = cmo_magic_number then
+      let cu_pos = input_binary_int ic in
+      seek_in ic cu_pos;
+      let cu = (input_value ic : compilation_unit) in
+      close_in ic;
+      print_cmo_infos cu
+    else if magic_number = cma_magic_number then
+      let toc_pos = input_binary_int ic in
+      seek_in ic toc_pos;
+      let toc = (input_value ic : library) in
+      close_in ic;
+      print_cma_infos toc
+    else if magic_number = cmi_magic_number then
+      let (name, sign, comps) = input_value ic in
+      let crcs = input_value ic in
+      close_in ic;
+      print_cmi_infos name sign comps crcs
+    else if magic_number = cmx_magic_number then
+      let ui = (input_value ic : Compilenv.unit_infos) in
+      let crc = Digest.input ic in
+      close_in ic;
+      print_cmx_infos (ui, crc)
+    else if magic_number = cmxa_magic_number then
+      let li = (input_value ic : library_infos) in
+      close_in ic;
+      List.iter print_cmx_infos li.lib_units
+    else
+      let pos_trailer = in_channel_length ic - len_magic_number in
+      let _ = seek_in ic pos_trailer in
+      let _ = really_input ic magic_number 0 len_magic_number in
+      if magic_number = Config.exec_magic_number then begin
+        dump_byte ic;
+        close_in ic
+      end
+      else
+        let offset = get_cmxs_info filename in
+        match offset with
+          | -1 -> raise Not_found
+          | -2 -> failwith "Cannot display info on .cmxs files!"
+          | _ ->
+              let _ = seek_in ic offset in
+              let header = (input_value ic : Natdynlink.dynheader) in
+              if header.magic = Natdynlink.dyn_magic_number
+              then begin
+                List.iter
+                  (fun ui ->
+                     print_general_infos
+                       ui.name
+                       ui.crc
+                       ui.defines
+                       ui.imports_cmi
+                       ui.imports_cmx)
+                  header.units;
+                close_in ic
+              end
+  with
+    | Failure s ->
+        close_in ic;
+        prerr_endline s;
+	exit 2
+    | _ ->
+        close_in ic;
+	Printf.eprintf "%s is not an object file!" filename;
+	exit 1
 
 let main() =
   for i = 1 to Array.length Sys.argv - 1 do
diff --git a/tools/objinfo_stubs.c b/tools/objinfo_stubs.c
new file mode 100644
index 0000000..2028518
--- /dev/null
+++ b/tools/objinfo_stubs.c
@@ -0,0 +1,56 @@
+
+#include "../byterun/mlvalues.h"
+#include "../byterun/alloc.h"
+
+#ifdef HAS_LIBBFD
+#include <string.h>
+#include <bfd.h>
+
+static unsigned long int get_cmxs_offset (char *file)
+{
+  unsigned int result = -1;
+
+  bfd *fd;
+  fd = bfd_openr(file, "default");
+  if (!fd) return -1;
+
+  if (bfd_check_format (fd, bfd_object)) {
+    asection *sec;
+    sec = bfd_get_section_by_name(fd, ".data");
+
+    if (sec) {
+      unsigned long long int offset = sec->filepos;
+      long st_size = bfd_get_dynamic_symtab_upper_bound (fd);
+
+      if (st_size > 0) {
+        asymbol **symbol_table;
+        symbol_table = malloc(st_size);
+
+        long sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table);
+        long i;
+        for (i = 0; i < sym_count; i++) {
+          if (!strcmp(symbol_table[i]->name, "caml_plugin_header")) {
+            result = offset + symbol_table[i]->value;
+          }
+        }
+
+        free(symbol_table);
+      }
+    }
+  }
+
+  bfd_close(fd);
+  return result;
+}
+#endif
+
+CAMLprim value caml_get_cmxs_offset(value file)
+{
+  return Val_long(
+#ifdef HAS_LIBBFD
+    get_cmxs_offset(String_val(file))
+#else
+    -2
+#endif
+  );
+}
-- 
1.7.0

From b52ad7d39cce9ed35d1fca0acfe4a69120003116 Mon Sep 17 00:00:00 2001
From: Mehdi Dogguy <mehdi@debian.org>
Date: Wed, 21 Apr 2010 19:38:02 +0200
Subject: [PATCH] Enhanced objinfo (updated) 2

---
 tools/Makefile.shared |   38 +++++--
 tools/dumpapprox.ml   |   97 ----------------
 tools/natdynlink.ml   |   31 +++++
 tools/objinfo.ml      |  291 ++++++++++++++++++++++++++++++++++++++-----------
 tools/objinfo_stubs.c |   57 ++++++++++
 5 files changed, 344 insertions(+), 170 deletions(-)
 delete mode 100644 tools/dumpapprox.ml
 create mode 100644 tools/natdynlink.ml
 create mode 100644 tools/objinfo_stubs.c

diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 477ba73..68c7624 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -225,21 +225,43 @@ clean::
 
 beforedepend:: opnames.ml
 
-# Dump .cmx files
+# Dump compilation units and bytecode binaries
 
-dumpapprox: dumpapprox.cmo
-	$(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo
+../asmcomp/debuginfo.cmo: ../asmcomp/debuginfo.cmi
+../asmcomp/clambda.cmo: ../asmcomp/debuginfo.cmo ../asmcomp/clambda.cmi
+../asmcomp/compilenv.cmo: ../asmcomp/compilenv.cmi
 
-clean::
-	rm -f dumpapprox
+OBJDEPS=../asmcomp/clambda.cmo ../typing/ident.cmo ../utils/tbl.cmo \
+	../utils/misc.cmo ../typing/path.cmo ../typing/types.cmo \
+	../typing/btype.cmo ../utils/config.cmo ../typing/predef.cmo \
+	../typing/datarepr.cmo ../utils/consistbl.cmo \
+	../typing/subst.cmo ../utils/clflags.cmo ../typing/env.cmo \
+	../asmcomp/compilenv.cmo ../bytecomp/bytesections.cmo\
+	natdynlink.cmo objinfo.cmo
+
+objinfo.cmo: objinfo.ml
+	$(CAMLC) $(LINKFLAGS) -c $(COMPFLAGS) $<
+
+OBJSTUBS=objinfo_stubs
+
+$(OBJSTUBS).o: $(OBJSTUBS).c
+	$(CAMLC) -pp "$(CPP)" -ccopt "-o $@ $(CFLAGS)" -c $^
 
-# Print imported interfaces for .cmo files
+dll$(OBJSTUBS).so: ocamlmklib $(OBJSTUBS).o
+# LIBBFD_CFLAGS should contain "-ldl -lbfd" when HAS_LIBBFD is defined
+	../boot/ocamlrun ./ocamlmklib -o $(OBJSTUBS) \
+		$(OBJSTUBS).o $(LIBBFD_CFLAGS)
 
-objinfo: objinfo.cmo
-	$(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo
+objinfo: dll$(OBJSTUBS).so $(OBJDEPS)
+	$(CAMLC) $(LINKFLAGS) -dllib dll$(OBJSTUBS).so \
+		-cclib -l$(OBJSTUBS) -o objinfo \
+		$(OBJSTUBS).o $(OBJDEPS)
 
 clean::
 	rm -f objinfo
+	rm -f objinfo.cm*
+	rm -f $(OBJSTUBS).o
+	rm -f dll$(OBJSTUBS).so
 
 # Scan object files for required primitives
 
diff --git a/tools/dumpapprox.ml b/tools/dumpapprox.ml
deleted file mode 100644
index 4270842..0000000
--- a/tools/dumpapprox.ml
+++ /dev/null
@@ -1,97 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Dump a .cmx file *)
-
-open Config
-open Format
-open Clambda
-open Compilenv
-
-let print_digest ppf d =
-  for i = 0 to String.length d - 1 do
-    print_string(Printf.sprintf "%02x" (Char.code d.[i]))
-  done
-
-let rec print_approx ppf = function
-    Value_closure(fundesc, approx) ->
-      printf "@[<2>function %s@ arity %i" fundesc.fun_label fundesc.fun_arity;
-      if fundesc.fun_closed then begin
-        printf "@ (closed)"
-      end;
-      if fundesc.fun_inline <> None then begin
-        printf "@ (inline)"
-      end;
-      printf "@ -> @ %a@]" print_approx approx
-  | Value_tuple approx ->
-      let tuple ppf approx =
-        for i = 0 to Array.length approx - 1 do
-          if i > 0 then printf ";@ ";
-          printf "%i: %a" i print_approx approx.(i)
-        done in
-      printf "@[<hov 1>(%a)@]" tuple approx
-  | Value_unknown ->
-      print_string "_"
-  | Value_integer n ->
-      print_int n
-  | Value_constptr n ->
-      print_int n; print_string "p"
-
-let print_name_crc (name, crc) =
-  printf "@ %s (%a)" name print_digest crc
-
-let print_infos (ui, crc) =
-  printf "Name: %s@." ui.ui_name;
-  printf "CRC of implementation: %a@." print_digest crc;
-  printf "@[<hov 2>Globals defined:";
-  List.iter (fun s -> printf "@ %s" s) ui.ui_defines;
-  printf "@]@.";
-  let pr_imports ppf imps = List.iter print_name_crc imps in
-  printf "@[<v 2>Interfaces imported:%a@]@." pr_imports ui.ui_imports_cmi;
-  printf "@[<v 2>Implementations imported:%a@]@." pr_imports ui.ui_imports_cmx;
-  printf "@[<v 2>Approximation:@ %a@]@." print_approx ui.ui_approx;
-  let pr_funs ppf fns =
-    List.iter (fun arity -> printf "@ %i" arity) fns in
-  printf "@[<2>Currying functions:%a@]@." pr_funs ui.ui_curry_fun;
-  printf "@[<2>Apply functions:%a@]@." pr_funs ui.ui_apply_fun
-
-let print_unit_info filename =
-  let ic = open_in_bin filename in
-  try
-    let buffer = String.create (String.length cmx_magic_number) in
-    really_input ic buffer 0 (String.length cmx_magic_number);
-    if buffer = cmx_magic_number then begin
-      let ui = (input_value ic : unit_infos) in
-      let crc = Digest.input ic in
-      close_in ic;
-      print_infos (ui, crc)
-    end else if buffer = cmxa_magic_number then begin
-      let li = (input_value ic : library_infos) in
-      close_in ic;
-      List.iter print_infos li.lib_units
-    end else begin
-      close_in ic;
-      prerr_endline "Wrong magic number";
-      exit 2
-    end
-  with End_of_file | Failure _ ->
-    close_in ic;
-    prerr_endline "Error reading file";
-    exit 2
-
-let main () =
-  print_unit_info Sys.argv.(1);
-  exit 0
-
-let _ = main ()
diff --git a/tools/natdynlink.ml b/tools/natdynlink.ml
new file mode 100644
index 0000000..f562f2b
--- /dev/null
+++ b/tools/natdynlink.ml
@@ -0,0 +1,31 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../../LICENSE.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Copied from other places to avoid dependencies *)
+
+type dynunit = {
+  name: string;
+  crc: Digest.t;
+  imports_cmi: (string * Digest.t) list;
+  imports_cmx: (string * Digest.t) list;
+  defines: string list;
+}
+
+type dynheader = {
+  magic: string;
+  units: dynunit list;
+}
+
+let dyn_magic_number = "Caml2007D001"
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index 943f83f..4f4b45e 100644
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -12,84 +12,245 @@
 
 (* $Id$ *)
 
-(* Dump a compilation unit description *)
+(* Dump a compilation unit description or a bytecode file *)
 
+open Format
 open Config
 open Cmo_format
+open Clambda
+open Natdynlink
+
+external get_cmxs_info : string -> int = "caml_get_cmxs_offset"
+
+let sprint_digest d =
+  let len = String.length d in
+  let rec sp string i d =
+    if i < len
+    then
+      let str = sprintf "%s%02x" string (Char.code d.[i]) in
+      sp str (i + 1) d
+    else string
+  in
+  sp "" 0 d
 
 let print_digest d =
-  for i = 0 to String.length d - 1 do
-    Printf.printf "%02x" (Char.code d.[i])
-  done
+  print_string (sprint_digest d)
 
-let print_info cu =
-  print_string "  Unit name: "; print_string cu.cu_name; print_newline();
-  print_string "  Interfaces imported:"; print_newline();
-  List.iter
-    (fun (name, digest) ->
-      print_string "\t"; print_digest digest; print_string "\t";
-      print_string name; print_newline())
-    cu.cu_imports;
-  print_string "  Uses unsafe features: ";
-  begin match cu.cu_primitives with
-    [] -> print_string "no"; print_newline()
-  | l  -> print_string "YES"; print_newline();
-          print_string "  Primitives declared in this module:";
-          print_newline();
-          List.iter
-            (fun name -> print_string "\t"; print_string name; print_newline())
-            l
-  end
-
-let print_spaced_string s = print_char ' '; print_string s
-
-let print_library_info lib =
-  print_string "  Force custom: ";
-  print_string (if lib.lib_custom then "YES" else "no");
-  print_newline();
-  print_string "  Extra C object files:";
+let input_stringlist ic len =
+  let get_string_list sect len =
+    let rec fold s e acc =
+      if e != len then
+        if sect.[e] = '\000' then
+          fold (e+1) (e+1) (String.sub sect s (e-s) :: acc)
+        else fold s (e+1) acc
+      else acc
+    in fold 0 0 []
+  in
+  let sect = String.create len in
+  let _ = really_input ic sect 0 len in
+  get_string_list sect len
+
+let print_name_crc (name, crc) =
+  printf "\n\t%s\t%s%!" (sprint_digest crc) name
+
+let print_prim name =
+  printf "\n\t%s%!" name
+
+let print_primitives prims =
+  printf "\nUses unsafe features: ";
+  match prims with
+    | [] -> printf "no@."
+    | l  ->
+        printf "YES@.";
+        printf "Primitives declared in this module:@?";
+        List.iter print_prim l;
+        print_newline ()
+
+let print_cmo_infos cu =
+  printf "Unit name: %s@." cu.cu_name;
+  print_string "Interfaces imported:";
+  List.iter print_name_crc cu.cu_imports;
+  print_primitives cu.cu_primitives
+
+let rec print_approx_infos ppf = function
+    Value_closure(fundesc, approx) ->
+      printf "@[<2>function %s@ arity %i"
+        fundesc.fun_label fundesc.fun_arity;
+      if fundesc.fun_closed then begin
+        printf "@ (closed)"
+      end;
+      if fundesc.fun_inline <> None then begin
+        printf "@ (inline)"
+      end;
+      printf "@ -> @ %a@]" print_approx_infos approx
+  | Value_tuple approx ->
+      let tuple ppf approx =
+        for i = 0 to Array.length approx - 1 do
+          if i > 0 then printf ";@ ";
+          printf "%i: %a" i print_approx_infos approx.(i)
+        done in
+      printf "@[<hov 1>(%a)@]" tuple approx
+  | Value_unknown ->
+      print_string "_"
+  | Value_integer n ->
+      print_int n
+  | Value_constptr n ->
+      print_int n; print_string "p"
+
+let print_spaced_string s =
+  printf " %s" s
+
+let print_cma_infos (lib : Cmo_format.library) =
+  printf "Force custom: %s@." (if lib.lib_custom then "YES" else "no");
+  printf "Extra C object files: %!";
   (* PR#4949: print in linking order *)
-  List.iter print_spaced_string (List.rev lib.lib_ccobjs); print_newline();
-  print_string "  Extra C options:";
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  print_string "\nExtra C options:";
   List.iter print_spaced_string lib.lib_ccopts; print_newline();
-  List.iter print_info lib.lib_units
+  List.iter print_cmo_infos lib.lib_units;
+  print_string "  Extra dynamically-loaded libraries:";
+  List.iter print_spaced_string lib.lib_dllibs; print_newline()
+
+let print_cmi_infos name sign comps crcs =
+  printf "Module name: %s\n%!" name;
+  printf "Interfaces imported:%!";
+  List.iter print_name_crc crcs;
+  print_newline ()
+
+let print_general_infos name crc defines cmi cmx =
+  let pr_imports _ imps = List.iter print_name_crc imps in
+  printf "Name: %s@." name;
+  printf "CRC of implementation: %s@." (Digest.to_hex crc);
+  printf "Globals defined: @?";
+  List.iter print_endline defines;
+  printf "Interfaces imported: %a@." pr_imports cmi;
+  printf "Implementations imported: %a@." pr_imports cmx
+
+open Compilenv
+
+let print_cmx_infos (ui, crc) =
+  print_general_infos
+    ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
+  printf "Approximation: %a@." print_approx_infos ui.ui_approx;
+  let pr_funs _ fns =
+    List.iter (fun arity -> printf " %i%!" arity) fns in
+  printf "Currying functions:%a@." pr_funs ui.ui_curry_fun;
+  printf "Apply functions:%a@." pr_funs ui.ui_apply_fun
+
+let p_title title = printf "%s:%!" title
+
+let p_section title = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print_name_crc l
+
+let p_list title print = function
+  | [] -> ()
+  | l ->
+      p_title title;
+      List.iter print l
 
-let print_intf_info name sign comps crcs =
-  print_string "  Module name: "; print_string name; print_newline();
-  print_string "  Interfaces imported:"; print_newline();
+let dump_byte ic =
+  Bytesections.read_toc ic;
+  let toc = Bytesections.toc () in
+  let toc = List.sort Pervasives.compare toc in
   List.iter
-    (fun (name, digest) ->
-      print_string "\t"; print_digest digest; print_string "\t";
-      print_string name; print_newline())
-    crcs
+    (fun (section, _) ->
+       try
+         let len = Bytesections.seek_section ic section in
+         if len > 0 then match section with
+           | "CRCS" ->
+               p_section
+                 "Imported Units"
+                 (input_value ic : (string * Digest.t) list)
+           | "DLLS" ->
+               p_list
+                 "Used Dlls"
+                 print_prim
+                 (input_stringlist ic len)
+           | "DLPT" ->
+               p_list
+                 "Additional Dll paths"
+                 print_prim
+                 (input_stringlist ic len)
+           | "PRIM" ->
+               print_primitives (input_stringlist ic len)
+           | _ -> ()
+       with _ -> ()
+    )
+    toc
 
 let dump_obj filename =
-  print_string "File "; print_string filename; print_newline();
   let ic = open_in_bin filename in
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
-  if buffer = cmo_magic_number then begin
-    let cu_pos = input_binary_int ic in
-    seek_in ic cu_pos;
-    let cu = (input_value ic : compilation_unit) in
-    close_in ic;
-    print_info cu
-  end else
-  if buffer = cma_magic_number then begin
-    let toc_pos = input_binary_int ic in
-    seek_in ic toc_pos;
-    let toc = (input_value ic : library) in
-    close_in ic;
-    print_library_info toc
-  end else
-  if buffer = cmi_magic_number then begin
-    let (name, sign, comps) = input_value ic in
-    let crcs = input_value ic in
-    close_in ic;
-    print_intf_info name sign comps crcs
-  end else begin
-    prerr_endline "Not an object file"; exit 2
-  end
+  try
+    let len_magic_number = String.length cmo_magic_number in
+    let magic_number = String.create len_magic_number in
+    really_input ic magic_number 0 len_magic_number;
+    if magic_number = cmo_magic_number then
+      let cu_pos = input_binary_int ic in
+      seek_in ic cu_pos;
+      let cu = (input_value ic : compilation_unit) in
+      close_in ic;
+      print_cmo_infos cu
+    else if magic_number = cma_magic_number then
+      let toc_pos = input_binary_int ic in
+      seek_in ic toc_pos;
+      let toc = (input_value ic : library) in
+      close_in ic;
+      print_cma_infos toc
+    else if magic_number = cmi_magic_number then
+      let (name, sign, comps) = input_value ic in
+      let crcs = input_value ic in
+      close_in ic;
+      print_cmi_infos name sign comps crcs
+    else if magic_number = cmx_magic_number then
+      let ui = (input_value ic : Compilenv.unit_infos) in
+      let crc = Digest.input ic in
+      close_in ic;
+      print_cmx_infos (ui, crc)
+    else if magic_number = cmxa_magic_number then
+      let li = (input_value ic : library_infos) in
+      close_in ic;
+      List.iter print_cmx_infos li.lib_units
+    else
+      let pos_trailer = in_channel_length ic - len_magic_number in
+      let _ = seek_in ic pos_trailer in
+      let _ = really_input ic magic_number 0 len_magic_number in
+      if magic_number = Config.exec_magic_number then begin
+        dump_byte ic;
+        close_in ic
+      end
+      else
+        let offset = get_cmxs_info filename in
+        match offset with
+          | -1 -> raise Not_found
+          | -2 -> failwith "Cannot display info on .cmxs files!"
+          | _ ->
+              let _ = seek_in ic offset in
+              let header = (input_value ic : Natdynlink.dynheader) in
+              if header.magic = Natdynlink.dyn_magic_number
+              then begin
+                List.iter
+                  (fun ui ->
+                     print_general_infos
+                       ui.name
+                       ui.crc
+                       ui.defines
+                       ui.imports_cmi
+                       ui.imports_cmx)
+                  header.units;
+                close_in ic
+              end
+  with
+    | Failure s ->
+        close_in ic;
+        prerr_endline s;
+	exit 2
+    | _ ->
+        close_in ic;
+	Printf.eprintf "%s is not an object file!" filename;
+	exit 1
 
 let main() =
   for i = 1 to Array.length Sys.argv - 1 do
diff --git a/tools/objinfo_stubs.c b/tools/objinfo_stubs.c
new file mode 100644
index 0000000..ed91e23
--- /dev/null
+++ b/tools/objinfo_stubs.c
@@ -0,0 +1,57 @@
+
+#include "../byterun/mlvalues.h"
+#include "../byterun/alloc.h"
+#include "../config/s.h"
+
+#ifdef HAS_LIBBFD
+#include <string.h>
+#include <bfd.h>
+
+static unsigned long int get_cmxs_offset (char *file)
+{
+  unsigned int result = -1;
+
+  bfd *fd;
+  fd = bfd_openr(file, "default");
+  if (!fd) return -1;
+
+  if (bfd_check_format (fd, bfd_object)) {
+    asection *sec;
+    sec = bfd_get_section_by_name(fd, ".data");
+
+    if (sec) {
+      unsigned long long int offset = sec->filepos;
+      long st_size = bfd_get_dynamic_symtab_upper_bound (fd);
+
+      if (st_size > 0) {
+        asymbol **symbol_table;
+        symbol_table = malloc(st_size);
+
+        long sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table);
+        long i;
+        for (i = 0; i < sym_count; i++) {
+          if (!strcmp(symbol_table[i]->name, "caml_plugin_header")) {
+            result = offset + symbol_table[i]->value;
+          }
+        }
+
+        free(symbol_table);
+      }
+    }
+  }
+
+  bfd_close(fd);
+  return result;
+}
+#endif
+
+CAMLprim value caml_get_cmxs_offset(value file)
+{
+  return Val_long(
+#ifdef HAS_LIBBFD
+    get_cmxs_offset(String_val(file))
+#else
+    -2
+#endif
+  );
+}
-- 
1.7.0