1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
6(*         Mehdi Dogguy, PPS laboratory, University Paris Diderot         *)
7(*                                                                        *)
8(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
9(*     en Automatique.                                                    *)
10(*   Copyright 2010 Mehdi Dogguy                                          *)
11(*                                                                        *)
12(*   All rights reserved.  This file is distributed under the terms of    *)
13(*   the GNU Lesser General Public License version 2.1, with the          *)
14(*   special exception on linking described in the file LICENSE.          *)
15(*                                                                        *)
16(**************************************************************************)
17
18(* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files
19   and on bytecode executables. *)
20
21open Printf
22open Misc
23open Config
24open Cmo_format
25
26(* Command line option to prevent printing approximation and function code *)
27let no_approx = ref false
28let no_code = ref false
29
30let input_stringlist ic len =
31  let get_string_list sect len =
32    let rec fold s e acc =
33      if e != len then
34        if sect.[e] = '\000' then
35          fold (e+1) (e+1) (String.sub sect s (e-s) :: acc)
36        else fold s (e+1) acc
37      else acc
38    in fold 0 0 []
39  in
40  let sect = really_input_string ic len in
41  get_string_list sect len
42
43let dummy_crc = String.make 32 '-'
44
45let print_name_crc (name, crco) =
46  let crc =
47    match crco with
48      None -> dummy_crc
49    | Some crc -> Digest.to_hex crc
50  in
51    printf "\t%s\t%s\n" crc name
52
53let print_line name =
54  printf "\t%s\n" name
55
56let print_required_global id =
57  printf "\t%s\n" (Ident.name id)
58
59let print_cmo_infos cu =
60  printf "Unit name: %s\n" cu.cu_name;
61  print_string "Interfaces imported:\n";
62  List.iter print_name_crc cu.cu_imports;
63  print_string "Required globals:\n";
64  List.iter print_required_global cu.cu_required_globals;
65  printf "Uses unsafe features: ";
66  (match cu.cu_primitives with
67    | [] -> printf "no\n"
68    | l  ->
69        printf "YES\n";
70        printf "Primitives declared in this module:\n";
71        List.iter print_line l);
72  printf "Force link: %s\n" (if cu.cu_force_link then "YES" else "no")
73
74let print_spaced_string s =
75  printf " %s" s
76
77let print_cma_infos (lib : Cmo_format.library) =
78  printf "Force custom: %s\n" (if lib.lib_custom then "YES" else "no");
79  printf "Extra C object files:";
80  (* PR#4949: print in linking order *)
81  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
82  printf "\nExtra C options:";
83  List.iter print_spaced_string lib.lib_ccopts;
84  printf "\n";
85  print_string "Extra dynamically-loaded libraries:";
86  List.iter print_spaced_string lib.lib_dllibs;
87  printf "\n";
88  List.iter print_cmo_infos lib.lib_units
89
90let print_cmi_infos name crcs =
91  printf "Unit name: %s\n" name;
92  printf "Interfaces imported:\n";
93  List.iter print_name_crc crcs
94
95let print_cmt_infos cmt =
96  let open Cmt_format in
97  printf "Cmt unit name: %s\n" cmt.cmt_modname;
98  print_string "Cmt interfaces imported:\n";
99  List.iter print_name_crc cmt.cmt_imports;
100  printf "Source file: %s\n"
101         (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f);
102  printf "Compilation flags:";
103  Array.iter print_spaced_string cmt.cmt_args;
104  printf "\nLoad path:";
105  List.iter print_spaced_string cmt.cmt_loadpath;
106  printf "\n";
107  printf "cmt interface digest: %s\n"
108    (match cmt.cmt_interface_digest with
109     | None -> ""
110     | Some crc -> Digest.to_hex crc)
111
112let print_general_infos name crc defines cmi cmx =
113  printf "Name: %s\n" name;
114  printf "CRC of implementation: %s\n" (Digest.to_hex crc);
115  printf "Globals defined:\n";
116  List.iter print_line defines;
117  printf "Interfaces imported:\n";
118  List.iter print_name_crc cmi;
119  printf "Implementations imported:\n";
120  List.iter print_name_crc cmx
121
122let print_global_table table =
123  printf "Globals defined:\n";
124  Tbl.iter
125    (fun id _ -> print_line (Ident.name id))
126    table.num_tbl
127
128open Cmx_format
129
130let print_cmx_infos (ui, crc) =
131  print_general_infos
132    ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx;
133  begin match ui.ui_export_info with
134  | Clambda approx ->
135    if not !no_approx then begin
136      printf "Clambda approximation:\n";
137      Format.fprintf Format.std_formatter "  %a@." Printclambda.approx approx
138    end else
139      Format.printf "Clambda unit@.";
140  | Flambda export ->
141    if not !no_approx || not !no_code then
142      printf "Flambda export information:\n"
143    else
144      printf "Flambda unit\n";
145    if not !no_approx then begin
146      let cu =
147        Compilation_unit.create (Ident.create_persistent ui.ui_name)
148          (Linkage_name.create "__dummy__")
149      in
150      Compilation_unit.set_current cu;
151      let root_symbols =
152        List.map (fun s ->
153            Symbol.unsafe_create cu (Linkage_name.create ("caml"^s)))
154          ui.ui_defines
155      in
156      Format.printf "approximations@ %a@.@."
157        Export_info.print_approx (export, root_symbols)
158    end;
159    if not !no_code then
160      Format.printf "functions@ %a@.@."
161        Export_info.print_functions export
162  end;
163  let pr_funs _ fns =
164    List.iter (fun arity -> printf " %d" arity) fns in
165  printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun;
166  printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun;
167  printf "Send functions:%a\n" pr_funs ui.ui_send_fun;
168  printf "Force link: %s\n" (if ui.ui_force_link then "YES" else "no")
169
170let print_cmxa_infos (lib : Cmx_format.library_infos) =
171  printf "Extra C object files:";
172  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
173  printf "\nExtra C options:";
174  List.iter print_spaced_string lib.lib_ccopts;
175  printf "\n";
176  List.iter print_cmx_infos lib.lib_units
177
178let print_cmxs_infos header =
179  List.iter
180    (fun ui ->
181       print_general_infos
182         ui.dynu_name
183         ui.dynu_crc
184         ui.dynu_defines
185         ui.dynu_imports_cmi
186         ui.dynu_imports_cmx)
187    header.dynu_units
188
189let p_title title = printf "%s:\n" title
190
191let p_section title = function
192  | [] -> ()
193  | l ->
194      p_title title;
195      List.iter print_name_crc l
196
197let p_list title print = function
198  | [] -> ()
199  | l ->
200      p_title title;
201      List.iter print l
202
203let dump_byte ic =
204  Bytesections.read_toc ic;
205  let toc = Bytesections.toc () in
206  let toc = List.sort Pervasives.compare toc in
207  List.iter
208    (fun (section, _) ->
209       try
210         let len = Bytesections.seek_section ic section in
211         if len > 0 then match section with
212           | "CRCS" ->
213               p_section
214                 "Imported units"
215                 (input_value ic : (string * Digest.t option) list)
216           | "DLLS" ->
217               p_list
218                 "Used DLLs"
219                 print_line
220                 (input_stringlist ic len)
221           | "DLPT" ->
222               p_list
223                 "Additional DLL paths"
224                 print_line
225                 (input_stringlist ic len)
226           | "PRIM" ->
227               p_list
228                 "Primitives used"
229                 print_line
230                 (input_stringlist ic len)
231           | "SYMB" ->
232               print_global_table (input_value ic)
233           | _ -> ()
234       with _ -> ()
235    )
236    toc
237
238let read_dyn_header filename ic =
239  let tempfile = Filename.temp_file "objinfo" ".out" in
240  let helper = Filename.concat Config.standard_library "objinfo_helper" in
241  try
242    try_finally
243      (fun () ->
244        let rc = Sys.command (sprintf "%s %s > %s"
245                                (Filename.quote helper)
246                                (Filename.quote filename)
247                                tempfile) in
248        if rc <> 0 then failwith "cannot read";
249        let tc = Scanf.Scanning.from_file tempfile in
250        try_finally
251          (fun () ->
252            let ofs = Scanf.bscanf tc "%Ld" (fun x -> x) in
253            LargeFile.seek_in ic ofs;
254            Some(input_value ic : dynheader))
255          (fun () -> Scanf.Scanning.close_in tc))
256      (fun () -> remove_file tempfile)
257  with Failure _ | Sys_error _ -> None
258
259let dump_obj filename =
260  printf "File %s\n" filename;
261  let ic = open_in_bin filename in
262  let len_magic_number = String.length cmo_magic_number in
263  let magic_number = really_input_string ic len_magic_number in
264  if magic_number = cmo_magic_number then begin
265    let cu_pos = input_binary_int ic in
266    seek_in ic cu_pos;
267    let cu = (input_value ic : compilation_unit) in
268    close_in ic;
269    print_cmo_infos cu
270  end else if magic_number = cma_magic_number then begin
271    let toc_pos = input_binary_int ic in
272    seek_in ic toc_pos;
273    let toc = (input_value ic : library) in
274    close_in ic;
275    print_cma_infos toc
276  end else if magic_number = cmi_magic_number ||
277              magic_number = cmt_magic_number then begin
278    close_in ic;
279    let cmi, cmt = Cmt_format.read filename in
280    begin match cmi with
281     | None -> ()
282     | Some cmi ->
283         print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs
284    end;
285    begin match cmt with
286     | None -> ()
287     | Some cmt -> print_cmt_infos cmt
288    end
289  end else if magic_number = cmx_magic_number then begin
290    let ui = (input_value ic : unit_infos) in
291    let crc = Digest.input ic in
292    close_in ic;
293    print_cmx_infos (ui, crc)
294  end else if magic_number = cmxa_magic_number then begin
295    let li = (input_value ic : library_infos) in
296    close_in ic;
297    print_cmxa_infos li
298  end else begin
299    let pos_trailer = in_channel_length ic - len_magic_number in
300    let _ = seek_in ic pos_trailer in
301    let magic_number = really_input_string ic len_magic_number in
302    if magic_number = Config.exec_magic_number then begin
303      dump_byte ic;
304      close_in ic
305    end else if Filename.check_suffix filename ".cmxs" then begin
306      flush stdout;
307      match read_dyn_header filename ic with
308      | None ->
309          printf "Unable to read info on file %s\n" filename;
310          exit 2
311      | Some header ->
312          if header.dynu_magic = Config.cmxs_magic_number then
313            print_cmxs_infos header
314          else begin
315            printf "Wrong magic number\n"; exit 2
316          end;
317          close_in ic
318    end else begin
319      printf "Not an OCaml object file\n"; exit 2
320    end
321  end
322
323let arg_list = [
324  "-no-approx", Arg.Set no_approx, " Do not print module approximation information";
325  "-no-code", Arg.Set no_code, " Do not print code from exported flambda functions";
326  "-args", Arg.Expand Arg.read_arg,
327     "<file> Read additional newline separated command line arguments \n\
328     \      from <file>";
329  "-args0", Arg.Expand Arg.read_arg0,
330     "<file> Read additional NUL separated command line arguments from \n\
331     \      <file>";
332]
333let arg_usage =
334   Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0)
335
336let main() =
337  Arg.parse_expand arg_list dump_obj arg_usage;
338  exit 0
339
340let _ = main ()
341