summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.depend5
-rw-r--r--Changes4
-rw-r--r--bytecomp/bytelink.ml36
-rw-r--r--bytecomp/bytesections.ml165
-rw-r--r--bytecomp/bytesections.mli81
-rw-r--r--bytecomp/meta.ml2
-rw-r--r--bytecomp/meta.mli2
-rw-r--r--bytecomp/symtable.ml24
-rw-r--r--debugger/symbols.ml20
-rw-r--r--tools/cmpbyt.ml37
-rw-r--r--tools/dumpobj.ml45
-rw-r--r--tools/objinfo.ml58
-rw-r--r--tools/stripdebug.ml41
-rw-r--r--toplevel/expunge.ml44
14 files changed, 327 insertions, 237 deletions
diff --git a/.depend b/.depend
index 5439e23dae..f672f1b123 100644
--- a/.depend
+++ b/.depend
@@ -2138,12 +2138,15 @@ bytecomp/instruct.cmi : \
typing/env.cmi
bytecomp/meta.cmo : \
bytecomp/instruct.cmi \
+ bytecomp/bytesections.cmi \
bytecomp/meta.cmi
bytecomp/meta.cmx : \
bytecomp/instruct.cmx \
+ bytecomp/bytesections.cmx \
bytecomp/meta.cmi
bytecomp/meta.cmi : \
- bytecomp/instruct.cmi
+ bytecomp/instruct.cmi \
+ bytecomp/bytesections.cmi
bytecomp/opcodes.cmo : \
bytecomp/opcodes.cmi
bytecomp/opcodes.cmx : \
diff --git a/Changes b/Changes
index e3c7d0e368..c39ea30eb8 100644
--- a/Changes
+++ b/Changes
@@ -475,8 +475,8 @@ Working version
- #11569: Remove hash type encoding
(Hyunggyu Jang, review by Gabriel Scherer and Florian Angeletti)
-- #11601, #11612, #11628, #11613: Clean up some global state handling
- in emitcode, bytepackager, bytegen, spill.
+- #11601, #11612, #11628, #11613, #11623: Clean up some global state handling
+ in emitcode, bytepackager, bytegen, bytesections, spill.
(Hugo Heuzard, Stefan Muenzel, review by Vincent Laviron, Gabriel Scherer
and Nathanaëlle Courant)
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index afc1a47efb..4e006a7a59 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -339,7 +339,7 @@ let link_bytecode ?final_name tolink exec_name standalone =
| Not_found -> raise (Error (File_not_found header))
| Sys_error msg -> raise (Error (Camlheader (header, msg)))
end;
- Bytesections.init_record outchan;
+ let toc_writer = Bytesections.init_record outchan in
(* The path to the bytecode interpreter (in use_runtime mode) *)
if String.length !Clflags.use_runtime > 0 && !Clflags.with_runtime then
begin
@@ -354,7 +354,7 @@ let link_bytecode ?final_name tolink exec_name standalone =
in
output_string outchan runtime;
output_char outchan '\n';
- Bytesections.record outchan "RNTM"
+ Bytesections.record toc_writer Bytesections.Name.RNTM
end;
(* The bytecode *)
let start_code = pos_out outchan in
@@ -376,37 +376,37 @@ let link_bytecode ?final_name tolink exec_name standalone =
(* The final STOP instruction *)
output_byte outchan Opcodes.opSTOP;
output_byte outchan 0; output_byte outchan 0; output_byte outchan 0;
- Bytesections.record outchan "CODE";
+ Bytesections.record toc_writer CODE;
(* DLL stuff *)
if standalone then begin
(* The extra search path for DLLs *)
output_string outchan (concat_null_terminated !Clflags.dllpaths);
- Bytesections.record outchan "DLPT";
+ Bytesections.record toc_writer DLPT;
(* The names of the DLLs *)
output_string outchan (concat_null_terminated sharedobjs);
- Bytesections.record outchan "DLLS"
+ Bytesections.record toc_writer DLLS
end;
(* The names of all primitives *)
Symtable.output_primitive_names outchan;
- Bytesections.record outchan "PRIM";
+ Bytesections.record toc_writer PRIM;
(* The table of global data *)
Emitcode.marshal_to_channel_with_possibly_32bit_compat
~filename:final_name ~kind:"bytecode executable"
outchan (Symtable.initial_global_table());
- Bytesections.record outchan "DATA";
+ Bytesections.record toc_writer DATA;
(* The map of global identifiers *)
Symtable.output_global_map outchan;
- Bytesections.record outchan "SYMB";
+ Bytesections.record toc_writer SYMB;
(* CRCs for modules *)
output_value outchan (extract_crc_interfaces());
- Bytesections.record outchan "CRCS";
+ Bytesections.record toc_writer CRCS;
(* Debug info *)
if !Clflags.debug then begin
output_debug_info outchan;
- Bytesections.record outchan "DBUG"
+ Bytesections.record toc_writer DBUG
end;
(* The table of contents and the trailer *)
- Bytesections.write_toc_and_trailer outchan;
+ Bytesections.write_toc_and_trailer toc_writer;
)
(* Output a string as a C array of unsigned ints *)
@@ -454,15 +454,15 @@ let output_cds_file outfile =
~always:(fun () -> close_out outchan)
~exceptionally:(fun () -> remove_file outfile)
(fun () ->
- Bytesections.init_record outchan;
+ let toc_writer = Bytesections.init_record outchan in
(* The map of global identifiers *)
Symtable.output_global_map outchan;
- Bytesections.record outchan "SYMB";
+ Bytesections.record toc_writer SYMB;
(* Debug info *)
output_debug_info outchan;
- Bytesections.record outchan "DBUG";
+ Bytesections.record toc_writer DBUG;
(* The table of contents and the trailer *)
- Bytesections.write_toc_and_trailer outchan;
+ Bytesections.write_toc_and_trailer toc_writer;
)
(* Output a bytecode executable as a C file *)
@@ -503,9 +503,9 @@ let link_bytecode_as_c tolink outfile with_main =
output_string outchan "\n};\n\n";
(* The sections *)
let sections =
- [ "SYMB", Symtable.data_global_map();
- "PRIM", Obj.repr(Symtable.data_primitive_names());
- "CRCS", Obj.repr(extract_crc_interfaces()) ] in
+ [ Bytesections.Name.SYMB, Symtable.data_global_map();
+ Bytesections.Name.PRIM, Obj.repr(Symtable.data_primitive_names());
+ Bytesections.Name.CRCS, Obj.repr(extract_crc_interfaces()) ] in
output_string outchan "static char caml_sections[] = {\n";
output_data_string outchan
(Marshal.to_string sections []);
diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml
index 2beb0761b3..30a1c0fbc9 100644
--- a/bytecomp/bytesections.ml
+++ b/bytecomp/bytesections.ml
@@ -15,31 +15,94 @@
(* Handling of sections in bytecode executable files *)
-(* List of all sections, in reverse order *)
-
-let section_table = ref ([] : (string * int) list)
+module Name = struct
+
+ type raw_name = string
+
+ type t =
+ | CODE (** bytecode *)
+ | CRCS (** crcs for modules *)
+ | DATA (** global data (constant) *)
+ | DBUG (** debug info *)
+ | DLLS (** dll names *)
+ | DLPT (** dll paths *)
+ | PRIM (** primitives names *)
+ | RNTM (** The path to the bytecode interpreter (use_runtime mode) *)
+ | SYMB (** global identifiers *)
+ | Other of raw_name
+
+ let of_string name =
+ match name with
+ | "CODE" -> CODE
+ | "DLPT" -> DLPT
+ | "DLLS" -> DLLS
+ | "DATA" -> DATA
+ | "PRIM" -> PRIM
+ | "SYMB" -> SYMB
+ | "DBUG" -> DBUG
+ | "CRCS" -> CRCS
+ | "RNTM" -> RNTM
+ | name ->
+ if String.length name <> 4 then
+ invalid_arg "Bytesections.Name.of_string: must be of size 4";
+ Other name
+
+ let to_string = function
+ | CODE -> "CODE"
+ | DLPT -> "DLPT"
+ | DLLS -> "DLLS"
+ | DATA -> "DATA"
+ | PRIM -> "PRIM"
+ | SYMB -> "SYMB"
+ | DBUG -> "DBUG"
+ | CRCS -> "CRCS"
+ | RNTM -> "RNTM"
+ | Other n -> n
+end
+
+type section_entry = {
+ name : Name.t;
+ pos : int;
+ len : int;
+}
+
+type section_table = {
+ sections : section_entry list;
+ first_pos : int
+}
(* Recording sections *)
-
-let section_beginning = ref 0
-
-let init_record outchan =
- section_beginning := pos_out outchan;
- section_table := []
-
-let record outchan name =
+type toc_writer = {
+ (* List of all sections, in reverse order *)
+ mutable section_table_rev : section_entry list;
+ mutable section_prev : int;
+ outchan : out_channel;
+}
+
+let init_record outchan : toc_writer =
let pos = pos_out outchan in
- section_table := (name, pos - !section_beginning) :: !section_table;
- section_beginning := pos
-
-let write_toc_and_trailer outchan =
+ { section_prev = pos;
+ section_table_rev = [];
+ outchan }
+
+let record t name =
+ let pos = pos_out t.outchan in
+ if pos < t.section_prev then
+ invalid_arg "Bytesections.record: out_channel offset moved backward";
+ let entry = {name; pos = t.section_prev; len = pos - t.section_prev} in
+ t.section_table_rev <- entry :: t.section_table_rev;
+ t.section_prev <- pos
+
+let write_toc_and_trailer t =
+ let section_table = List.rev t.section_table_rev in
List.iter
- (fun (name, len) ->
- output_string outchan name; output_binary_int outchan len)
- (List.rev !section_table);
- output_binary_int outchan (List.length !section_table);
- output_string outchan Config.exec_magic_number;
- section_table := [];
+ (fun {name; pos = _; len} ->
+ let name = Name.to_string name in
+ assert (String.length name = 4);
+ output_string t.outchan name; output_binary_int t.outchan len)
+ section_table;
+ output_binary_int t.outchan (List.length section_table);
+ output_string t.outchan Config.exec_magic_number
(* Read the table of sections from a bytecode executable *)
@@ -53,49 +116,49 @@ let read_toc ic =
really_input_string ic (String.length Config.exec_magic_number)
in
if header <> Config.exec_magic_number then raise Bad_magic_number;
- seek_in ic (pos_trailer - 8 * num_sections);
- section_table := [];
+ let toc_pos = pos_trailer - 8 * num_sections in
+ seek_in ic toc_pos;
+ let section_table_rev = ref [] in
for _i = 1 to num_sections do
- let name = really_input_string ic 4 in
+ let name = Name.of_string (really_input_string ic 4) in
let len = input_binary_int ic in
- section_table := (name, len) :: !section_table
- done
+ section_table_rev := (name, len) :: !section_table_rev
+ done;
+ let first_pos, sections =
+ List.fold_left (fun (pos, l) (name, len) ->
+ let section = {name; pos = pos - len; len} in
+ (pos - len, section :: l)) (toc_pos, []) !section_table_rev
+ in
+ { sections; first_pos }
+
+let all t = t.sections
-(* Return the current table of contents *)
+let pos_first_section t = t.first_pos
-let toc () = List.rev !section_table
+let find_section t name =
+ let rec find = function
+ | [] -> raise Not_found
+ | {name = n; pos; len} :: rest ->
+ if n = name
+ then pos, len
+ else find rest
+ in find t.sections
(* Position ic at the beginning of the section named "name",
and return the length of that section. Raise Not_found if no
such section exists. *)
-let seek_section ic name =
- let rec seek_sec curr_ofs = function
- [] -> raise Not_found
- | (n, len) :: rem ->
- if n = name
- then begin seek_in ic (curr_ofs - len); len end
- else seek_sec (curr_ofs - len) rem in
- seek_sec (in_channel_length ic - 16 - 8 * List.length !section_table)
- !section_table
+let seek_section t ic name =
+ let pos, len = find_section t name in
+ seek_in ic pos; len
(* Return the contents of a section, as a string *)
-let read_section_string ic name =
- really_input_string ic (seek_section ic name)
+let read_section_string t ic name =
+ really_input_string ic (seek_section t ic name)
(* Return the contents of a section, as marshalled data *)
-let read_section_struct ic name =
- ignore (seek_section ic name);
+let read_section_struct t ic name =
+ ignore (seek_section t ic name);
input_value ic
-
-(* Return the position of the beginning of the first section *)
-
-let pos_first_section ic =
- in_channel_length ic - 16 - 8 * List.length !section_table -
- List.fold_left (fun total (_name, len) -> total + len) 0 !section_table
-
-let reset () =
- section_table := [];
- section_beginning := 0
diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli
index 22e1a3bb6a..3d287932ac 100644
--- a/bytecomp/bytesections.mli
+++ b/bytecomp/bytesections.mli
@@ -15,43 +15,74 @@
(* Handling of sections in bytecode executable files *)
+
+module Name : sig
+
+ type raw_name = private string
+
+ type t =
+ | CODE (** bytecode *)
+ | CRCS (** crcs for modules *)
+ | DATA (** global data (constant) *)
+ | DBUG (** debug info *)
+ | DLLS (** dll names *)
+ | DLPT (** dll paths *)
+ | PRIM (** primitives names *)
+ | RNTM (** The path to the bytecode interpreter (use_runtime mode) *)
+ | SYMB (** global identifiers *)
+ | Other of raw_name
+
+ val of_string : string -> t
+ (** @raise Invalid_argument if the input is not of size 4 *)
+
+ val to_string : t -> string
+end
+
(** Recording sections written to a bytecode executable file *)
-val init_record: out_channel -> unit
- (* Start recording sections from the current position in out_channel *)
+type toc_writer
-val record: out_channel -> string -> unit
- (* Record the current position in the out_channel as the end of
- the section with the given name *)
+val init_record: out_channel -> toc_writer
+(** Start recording sections from the current position in out_channel *)
-val write_toc_and_trailer: out_channel -> unit
- (* Write the table of contents and the standard trailer for bytecode
- executable files *)
+val record: toc_writer -> Name.t -> unit
+(** Record the current position in the out_channel as the end of
+ the section with the given name. *)
+
+val write_toc_and_trailer: toc_writer -> unit
+(** Write the table of contents and the standard trailer for bytecode
+ executable files *)
(** Reading sections from a bytecode executable file *)
-val read_toc: in_channel -> unit
- (* Read the table of sections from a bytecode executable *)
+type section_entry = {
+ name : Name.t; (** name of the section. *)
+ pos : int; (** byte offset at which the section starts. *)
+ len : int; (** length of the section. *)
+}
+
+type section_table
exception Bad_magic_number
- (* Raised by [read_toc] if magic number doesn't match *)
-val toc: unit -> (string * int) list
- (* Return the current table of contents as a list of
- (section name, section length) pairs. *)
+val read_toc: in_channel -> section_table
+(** Read the table of sections from a bytecode executable.
+ Raise [Bad_magic_number] if magic number doesn't match *)
-val seek_section: in_channel -> string -> int
- (* Position the input channel at the beginning of the section named "name",
- and return the length of that section. Raise Not_found if no
- such section exists. *)
+val seek_section: section_table -> in_channel -> Name.t -> int
+(** Position the input channel at the beginning of the section named "name",
+ and return the length of that section. Raise Not_found if no
+ such section exists. *)
-val read_section_string: in_channel -> string -> string
- (* Return the contents of a section, as a string *)
+val read_section_string: section_table -> in_channel -> Name.t -> string
+(** Return the contents of a section, as a string. *)
-val read_section_struct: in_channel -> string -> 'a
- (* Return the contents of a section, as marshalled data *)
+val read_section_struct: section_table -> in_channel -> Name.t -> 'a
+(** Return the contents of a section, as marshalled data. *)
-val pos_first_section: in_channel -> int
- (* Return the position of the beginning of the first section *)
+val all : section_table -> section_entry list
+(** Returns all [section_entry] from a [section_table] in increasing
+ position order. *)
-val reset: unit -> unit
+val pos_first_section : section_table -> int
+(** Return the position of the beginning of the first section *)
diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
index db2ba1557c..6e0972478f 100644
--- a/bytecomp/meta.ml
+++ b/bytecomp/meta.ml
@@ -25,5 +25,5 @@ external release_bytecode : bytecode -> unit
= "caml_static_release_bytecode"
external invoke_traced_function : Obj.raw_data -> Obj.t -> Obj.t -> Obj.t
= "caml_invoke_traced_function"
-external get_section_table : unit -> (string * Obj.t) list
+external get_section_table : unit -> (Bytesections.Name.t * Obj.t) list
= "caml_get_section_table"
diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli
index 6ce6ea0316..daa53c141b 100644
--- a/bytecomp/meta.mli
+++ b/bytecomp/meta.mli
@@ -27,5 +27,5 @@ external release_bytecode : bytecode -> unit
= "caml_static_release_bytecode"
external invoke_traced_function : Obj.raw_data -> Obj.t -> Obj.t -> Obj.t
= "caml_invoke_traced_function"
-external get_section_table : unit -> (string * Obj.t) list
+external get_section_table : unit -> (Bytesections.Name.t * Obj.t) list
= "caml_get_section_table"
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index f196ad6ed6..97b6b784c1 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -275,8 +275,8 @@ let update_global_table () =
executable file (normal case) or from linked-in data (-output-obj). *)
type section_reader = {
- read_string: string -> string;
- read_struct: string -> Obj.t;
+ read_string: Bytesections.Name.t -> string;
+ read_struct: Bytesections.Name.t -> Obj.t;
close_reader: unit -> unit
}
@@ -284,16 +284,17 @@ let read_sections () =
try
let sections = Meta.get_section_table () in
{ read_string =
- (fun name -> (Obj.magic(List.assoc name sections) : string));
+ (fun name ->
+ (Obj.magic(List.assoc name sections) : string));
read_struct =
(fun name -> List.assoc name sections);
close_reader =
(fun () -> ()) }
with Not_found ->
let ic = open_in_bin Sys.executable_name in
- Bytesections.read_toc ic;
- { read_string = Bytesections.read_section_string ic;
- read_struct = Bytesections.read_section_struct ic;
+ let section_table = Bytesections.read_toc ic in
+ { read_string = Bytesections.read_section_string section_table ic;
+ read_struct = Bytesections.read_section_struct section_table ic;
close_reader = fun () -> close_in ic }
(* Initialize the linker for toplevel use *)
@@ -302,20 +303,23 @@ let init_toplevel () =
try
let sect = read_sections () in
(* Locations of globals *)
- global_table := (Obj.magic (sect.read_struct "SYMB") : GlobalMap.t);
+ global_table :=
+ (Obj.magic (sect.read_struct Bytesections.Name.SYMB) : GlobalMap.t);
(* Primitives *)
- let prims = Misc.split_null_terminated (sect.read_string "PRIM") in
+ let prims =
+ Misc.split_null_terminated (sect.read_string Bytesections.Name.PRIM) in
c_prim_table := PrimMap.empty;
List.iter set_prim_table prims;
(* DLL initialization *)
let dllpaths =
- try Misc.split_null_terminated (sect.read_string "DLPT")
+ try Misc.split_null_terminated (sect.read_string Bytesections.Name.DLPT)
with Not_found -> [] in
Dll.init_toplevel dllpaths;
(* Recover CRC infos for interfaces *)
let crcintfs =
try
- (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list)
+ (Obj.magic (sect.read_struct Bytesections.Name.CRCS)
+ : (string * Digest.t option) list)
with Not_found -> [] in
(* Done *)
sect.close_reader();
diff --git a/debugger/symbols.ml b/debugger/symbols.ml
index 8ed9b9db76..36f8f874eb 100644
--- a/debugger/symbols.ml
+++ b/debugger/symbols.ml
@@ -56,16 +56,18 @@ let relocate_event orig ev =
let read_symbols' bytecode_file =
let ic = open_in_bin bytecode_file in
- begin try
- Bytesections.read_toc ic;
- ignore(Bytesections.seek_section ic "SYMB");
- with Bytesections.Bad_magic_number | Not_found ->
- prerr_string bytecode_file; prerr_endline " is not a bytecode file.";
- raise Toplevel
- end;
+ let toc =
+ try
+ let toc = Bytesections.read_toc ic in
+ ignore(Bytesections.seek_section toc ic Bytesections.Name.SYMB);
+ toc
+ with Bytesections.Bad_magic_number | Not_found ->
+ prerr_string bytecode_file; prerr_endline " is not a bytecode file.";
+ raise Toplevel
+ in
Symtable.restore_state (input_value ic);
begin try
- ignore (Bytesections.seek_section ic "DBUG")
+ ignore (Bytesections.seek_section toc ic Bytesections.Name.DBUG)
with Not_found ->
prerr_string bytecode_file; prerr_endline " has no debugging info.";
raise Toplevel
@@ -84,7 +86,7 @@ let read_symbols' bytecode_file =
List.fold_left (fun s e -> String.Set.add e s) !dirs (input_value ic)
done;
begin try
- ignore (Bytesections.seek_section ic "CODE")
+ ignore (Bytesections.seek_section toc ic Bytesections.Name.CODE)
with Not_found ->
(* The file contains only debugging info,
loading mode is forced to "manual" *)
diff --git a/tools/cmpbyt.ml b/tools/cmpbyt.ml
index 75f9dacd47..d56c508a0d 100644
--- a/tools/cmpbyt.ml
+++ b/tools/cmpbyt.ml
@@ -18,10 +18,6 @@
open Printf
-let readtoc ic =
- Bytesections.read_toc ic;
- (Bytesections.toc(), Bytesections.pos_first_section ic)
-
type cmpresult = Same | Differ of int
let rec cmpbytes ic1 ic2 len ofs =
@@ -30,25 +26,24 @@ let rec cmpbytes ic1 ic2 len ofs =
if c1 = c2 then cmpbytes ic1 ic2 (len - 1) (ofs + 1) else Differ ofs
end
-let skip_section name =
- name = "DBUG"
+let skip_section (name : Bytesections.Name.t) =
+ match name with
+ | DBUG -> true
+ | _ -> false
let cmpbyt file1 file2 =
+ let open Bytesections in
let ic1 = open_in_bin file1 in
- let (toc1, pos1) = readtoc ic1 in
+ let toc1 = Bytesections.read_toc ic1 |> Bytesections.all in
let ic2 = open_in_bin file2 in
- let (toc2, pos2) = readtoc ic2 in
- seek_in ic1 pos1;
- seek_in ic2 pos2;
+ let toc2 = Bytesections.read_toc ic2 |> Bytesections.all in
let rec cmpsections t1 t2 =
match t1, t2 with
| [], [] ->
true
- | (name1, len1) :: t1, t2 when skip_section name1 ->
- seek_in ic1 (pos_in ic1 + len1);
- cmpsections t1 t2
- | t1, (name2, len2) :: t2 when skip_section name2 ->
- seek_in ic2 (pos_in ic2 + len2);
+ | s1 :: t1, t2 when skip_section s1.name ->
+ cmpsections t1 t2
+ | t1, s2 :: t2 when skip_section s2.name ->
cmpsections t1 t2
| [], _ ->
eprintf "%s has more sections than %s\n" file2 file1;
@@ -56,17 +51,21 @@ let cmpbyt file1 file2 =
| _, [] ->
eprintf "%s has more sections than %s\n" file1 file2;
false
- | (name1, len1) :: t1, (name2, len2) :: t2 ->
+ | s1 :: t1, s2 :: t2 ->
+ let name1 = Bytesections.Name.to_string s1.name
+ and name2 = Bytesections.Name.to_string s2.name in
if name1 <> name2 then begin
eprintf "Section mismatch: %s (in %s) / %s (in %s)\n"
name1 file1 name2 file2;
false
- end else if len1 <> len2 then begin
+ end else if s1.len <> s2.len then begin
eprintf "Length of section %s differ: %d (in %s) / %d (in %s)\n"
- name1 len1 file1 len2 file2;
+ name1 s1.len file1 s2.len file2;
false
end else begin
- match cmpbytes ic1 ic2 len1 0 with
+ seek_in ic1 s1.pos;
+ seek_in ic2 s2.pos;
+ match cmpbytes ic1 ic2 s1.len 0 with
| Differ ofs ->
eprintf "Files %s and %s differ: section %s, offset %d\n"
file1 file2 name1 ofs;
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 004e1af494..9ec07fd213 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -47,7 +47,6 @@ let inputs ic =
(* Global variables *)
type global_table_entry =
- Empty
| Global of Ident.t
| Constant of Obj.t
@@ -152,7 +151,6 @@ let print_getglobal_name ic =
else match !globals.(n) with
Global id -> print_string(Ident.name id)
| Constant obj -> print_obj obj
- | _ -> print_string "???"
end
let print_setglobal_name ic =
@@ -480,32 +478,31 @@ let dump_obj ic =
(* Print an executable file *)
let dump_exe ic =
- Bytesections.read_toc ic;
- (* Read the primitive table from an executable *)
- let prims = Bytesections.read_section_string ic "PRIM" in
+ let toc = Bytesections.read_toc ic in
+(* Read the primitive table from an executable *)
+ let prims = Bytesections.read_section_string toc ic Bytesections.Name.PRIM in
primitives := Array.of_list (Misc.split_null_terminated prims);
- ignore(Bytesections.seek_section ic "DATA");
- let init_data = (input_value ic : Obj.t array) in
- globals := Array.make (Array.length init_data) Empty;
- for i = 0 to Array.length init_data - 1 do
- !globals.(i) <- Constant (init_data.(i))
- done;
- ignore(Bytesections.seek_section ic "SYMB");
- let sym_table = (input_value ic : Symtable.global_map) in
+ let init_data : Obj.t array =
+ Bytesections.read_section_struct toc ic Bytesections.Name.DATA in
+ globals := Array.map (fun x -> Constant x) init_data;
+ let sym_table : Symtable.global_map =
+ Bytesections.read_section_struct toc ic Bytesections.Name.SYMB in
Symtable.iter_global_map
(fun id pos -> !globals.(pos) <- Global id) sym_table;
- begin try
- ignore (Bytesections.seek_section ic "DBUG");
- let num_eventlists = input_binary_int ic in
- for _i = 1 to num_eventlists do
- let orig = input_binary_int ic in
- let evl = (input_value ic : debug_event list) in
- ignore (input_value ic); (* Skip the list of absolute directory names *)
- record_events orig evl
- done
- with Not_found -> ()
+ begin
+ match Bytesections.seek_section toc ic Bytesections.Name.DBUG with
+ | exception Not_found -> ()
+ | (_ : int) ->
+ let num_eventlists = input_binary_int ic in
+ for _i = 1 to num_eventlists do
+ let orig = input_binary_int ic in
+ let evl = (input_value ic : debug_event list) in
+ (* Skip the list of absolute directory names *)
+ ignore (input_value ic);
+ record_events orig evl
+ done
end;
- let code_size = Bytesections.seek_section ic "CODE" in
+ let code_size = Bytesections.seek_section toc ic Bytesections.Name.CODE in
print_code ic code_size
let arg_list = [
diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index f4d4188f4b..e325fb0558 100644
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -19,7 +19,6 @@
and on bytecode executables. *)
open Printf
-open Misc
open Cmo_format
(* Command line options to prevent printing approximation,
@@ -32,10 +31,6 @@ let shape = ref false
module Magic_number = Misc.Magic_number
-let input_stringlist ic len =
- let sect = really_input_string ic len in
- split_null_terminated sect
-
let dummy_crc = String.make 32 '-'
let null_crc = String.make 32 '0'
@@ -211,39 +206,38 @@ let p_list title print = function
List.iter print l
let dump_byte ic =
- Bytesections.read_toc ic;
- let toc = Bytesections.toc () in
- let toc = List.sort Stdlib.compare toc in
+ let toc = Bytesections.read_toc ic in
+ let all = Bytesections.all toc in
List.iter
- (fun (section, _) ->
+ (fun {Bytesections.name = section; len; _} ->
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 option) list)
- | "DLLS" ->
- p_list
- "Used DLLs"
- print_line
- (input_stringlist ic len)
- | "DLPT" ->
- p_list
- "Additional DLL paths"
- print_line
- (input_stringlist ic len)
- | "PRIM" ->
- p_list
- "Primitives used"
- print_line
- (input_stringlist ic len)
- | "SYMB" ->
- print_global_table (input_value ic)
+ | CRCS ->
+ let imported_units : (string * Digest.t option) list =
+ Bytesections.read_section_struct toc ic section in
+ p_section "Imported units" imported_units
+ | DLLS ->
+ let dlls =
+ Bytesections.read_section_string toc ic section
+ |> Misc.split_null_terminated in
+ p_list "Used DLLs" print_line dlls
+ | DLPT ->
+ let dll_paths =
+ Bytesections.read_section_string toc ic section
+ |> Misc.split_null_terminated in
+ p_list "Additional DLL paths" print_line dll_paths
+ | PRIM ->
+ let prims =
+ Bytesections.read_section_string toc ic section
+ |> Misc.split_null_terminated in
+ p_list "Primitives used" print_line prims
+ | SYMB ->
+ let symb = Bytesections.read_section_struct toc ic section in
+ print_global_table symb
| _ -> ()
with _ -> ()
)
- toc
+ all
let find_dyn_offset filename =
match Binutils.read filename with
diff --git a/tools/stripdebug.ml b/tools/stripdebug.ml
index e5f7c2d28c..38aba4993f 100644
--- a/tools/stripdebug.ml
+++ b/tools/stripdebug.ml
@@ -23,40 +23,37 @@ let remove_header = ref false
let remove_DBUG = ref true
let remove_CRCS = ref false
-let remove_section = function
- | "DBUG" -> !remove_DBUG
- | "CRCS" -> !remove_CRCS
+let remove_section (s : Bytesections.Name.t) =
+ match s with
+ | DBUG -> !remove_DBUG
+ | CRCS -> !remove_CRCS
| _ -> false
let stripdebug infile outfile =
let ic = open_in_bin infile in
- Bytesections.read_toc ic;
- let toc = Bytesections.toc() in
- let pos_first_section = Bytesections.pos_first_section ic in
+ let toc = Bytesections.read_toc ic in
let oc =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
outfile in
- if !remove_header then begin
- (* Skip the #! header, going straight to the first section. *)
- seek_in ic pos_first_section
- end else begin
+ if not !remove_header then begin
(* Copy header up to first section *)
seek_in ic 0;
- copy_file_chunk ic oc pos_first_section
+ let header_length = Bytesections.pos_first_section toc in
+ copy_file_chunk ic oc header_length
end;
- (* Copy each section except those to be removed *)
- Bytesections.init_record oc;
+ (* Copy each section except DBUG and CRCS *)
+ let toc_writer = Bytesections.init_record oc in
List.iter
- (fun (name, len) ->
- if remove_section name then begin
- seek_in ic (pos_in ic + len)
- end else begin
- copy_file_chunk ic oc len;
- Bytesections.record oc name
- end)
- toc;
+ (fun {Bytesections.name; pos; len} ->
+ if not (remove_section name) then begin
+ seek_in ic pos;
+ copy_file_chunk ic oc len;
+ Bytesections.record toc_writer name
+ end
+ )
+ (Bytesections.all toc);
(* Rewrite the toc and trailer *)
- Bytesections.write_toc_and_trailer oc;
+ Bytesections.write_toc_and_trailer toc_writer;
(* Done *)
close_in ic;
close_out oc
diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
index 2a756573c0..a8ad126dd6 100644
--- a/toplevel/expunge.ml
+++ b/toplevel/expunge.ml
@@ -45,33 +45,33 @@ let main () =
to_keep := String.Set.add (String.capitalize_ascii Sys.argv.(i)) !to_keep
done;
let ic = open_in_bin input_name in
- Bytesections.read_toc ic;
- let toc = Bytesections.toc() in
- let pos_first_section = Bytesections.pos_first_section ic in
+ let toc = Bytesections.read_toc ic in
+ seek_in ic 0;
let oc =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
- output_name in
- (* Copy the file up to the symbol section as is *)
- seek_in ic 0;
- copy_file_chunk ic oc pos_first_section;
+ output_name in
+ let first_pos = Bytesections.pos_first_section toc in
+ (* Copy the file up to the first section as is *)
+ copy_file_chunk ic oc first_pos;
(* Copy each section, modifying the symbol section in passing *)
- Bytesections.init_record oc;
+ let toc_writer = Bytesections.init_record oc in
List.iter
- (fun (name, len) ->
- begin match name with
- "SYMB" ->
- let global_map = (input_value ic : Symtable.global_map) in
- output_value oc (expunge_map global_map)
- | "CRCS" ->
- let crcs = (input_value ic : (string * Digest.t option) list) in
- output_value oc (expunge_crcs crcs)
- | _ ->
- copy_file_chunk ic oc len
- end;
- Bytesections.record oc name)
- toc;
+ (fun {Bytesections.name; pos; len} ->
+ seek_in ic pos;
+ begin match name with
+ SYMB ->
+ let global_map : Symtable.global_map = input_value ic in
+ output_value oc (expunge_map global_map)
+ | CRCS ->
+ let crcs : (string * Digest.t option) list = input_value ic in
+ output_value oc (expunge_crcs crcs)
+ | _ ->
+ copy_file_chunk ic oc len
+ end;
+ Bytesections.record toc_writer name)
+ (Bytesections.all toc);
(* Rewrite the toc and trailer *)
- Bytesections.write_toc_and_trailer oc;
+ Bytesections.write_toc_and_trailer toc_writer;
(* Done *)
close_in ic;
close_out oc
View Lorry Controller Status