1 (***********************************************************************)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
7 (* Copyright 2002 Institut National de Recherche en Informatique et *)
8 (* en Automatique. All rights reserved. This file is distributed *)
9 (* under the terms of the Q Public License version 1.0. *)
11 (***********************************************************************)
13 (* $Id: bytepackager.ml 9221 2009-04-02 09:06:33Z xclerc $ *)
15 (* "Package" a set of .cmo files into one .cmo file having the
16 original compilation units as sub-modules. *)
23 Forward_reference of string * Ident.t
24 | Multiple_definition of string * Ident.t
25 | Not_an_object_file of string
26 | Illegal_renaming of string * string
27 | File_not_found of string
29 exception Error of error
31 (* References accumulating informations on the .cmo files *)
33 let relocs = ref ([] : (reloc_info * int) list)
34 let events = ref ([] : debug_event list)
35 let primitives = ref ([] : string list)
36 let force_link = ref false
38 (* Record a relocation. Update its offset, and rename GETGLOBAL and
39 SETGLOBAL relocations that correspond to one of the units being
42 let rename_relocation objfile mapping defined base (rel, ofs) =
47 let id' = List.assoc id mapping in
48 if List.mem id defined
49 then Reloc_getglobal id'
50 else raise(Error(Forward_reference(objfile, id)))
54 | Reloc_setglobal id ->
56 let id' = List.assoc id mapping in
57 if List.mem id defined
58 then raise(Error(Multiple_definition(objfile, id)))
59 else Reloc_setglobal id'
65 relocs := (rel', base + ofs) :: !relocs
67 (* Record and relocate a debugging event *)
69 let relocate_debug base prefix subst ev =
70 let ev' = { ev with ev_pos = base + ev.ev_pos;
71 ev_module = prefix ^ "." ^ ev.ev_module;
72 ev_typsubst = Subst.compose ev.ev_typsubst subst } in
73 events := ev' :: !events
75 (* Read the unit information from a .cmo file. *)
77 type pack_member_kind = PM_intf | PM_impl of compilation_unit
82 pm_kind: pack_member_kind }
84 let read_member_info file =
86 String.capitalize(Filename.basename(chop_extensions file)) in
88 if Filename.check_suffix file ".cmo" then begin
89 let ic = open_in_bin file in
91 let buffer = String.create (String.length Config.cmo_magic_number) in
92 really_input ic buffer 0 (String.length Config.cmo_magic_number);
93 if buffer <> Config.cmo_magic_number then
94 raise(Error(Not_an_object_file file));
95 let compunit_pos = input_binary_int ic in
96 seek_in ic compunit_pos;
97 let compunit = (input_value ic : compilation_unit) in
98 if compunit.cu_name <> name
99 then raise(Error(Illegal_renaming(file, compunit.cu_name)));
107 { pm_file = file; pm_name = name; pm_kind = kind }
109 (* Read the bytecode from a .cmo file.
110 Write bytecode to channel [oc].
111 Rename globals as indicated by [mapping] in reloc info.
112 Accumulate relocs, debug info, etc.
113 Return size of bytecode. *)
115 let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit =
116 let ic = open_in_bin objfile in
118 Bytelink.check_consistency objfile compunit;
120 (rename_relocation objfile mapping defined ofs)
122 primitives := compunit.cu_primitives @ !primitives;
123 if compunit.cu_force_link then force_link := true;
124 seek_in ic compunit.cu_pos;
125 Misc.copy_file_chunk ic oc compunit.cu_codesize;
126 if !Clflags.debug && compunit.cu_debug > 0 then begin
127 seek_in ic compunit.cu_debug;
128 List.iter (relocate_debug ofs prefix subst) (input_value ic);
136 (* Same, for a list of .cmo and .cmi files.
137 Return total size of bytecode. *)
139 let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function
145 rename_append_bytecode_list oc mapping defined ofs prefix subst rem
146 | PM_impl compunit ->
148 rename_append_bytecode oc mapping defined ofs prefix subst
149 m.pm_file compunit in
150 let id = Ident.create_persistent m.pm_name in
151 let root = Path.Pident (Ident.create_persistent prefix) in
152 rename_append_bytecode_list
153 oc mapping (id :: defined)
154 (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem
156 (* Generate the code that builds the tuple representing the package module *)
158 let build_global_target oc target_name members mapping pos coercion =
164 | PM_impl _ -> Some id2)
167 Translmod.transl_package
168 components (Ident.create_persistent target_name) coercion in
170 Bytegen.compile_implementation target_name lam in
172 Emitcode.to_packed_file oc instrs in
173 relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs
175 (* Build the .cmo file obtained by packaging the given .cmo files. *)
177 let package_object_files files targetfile targetname coercion =
179 map_left_right read_member_info files in
181 List.map (fun m -> m.pm_name) members in
185 (Ident.create_persistent name,
186 Ident.create_persistent(targetname ^ "." ^ name)))
188 let oc = open_out_bin targetfile in
190 output_string oc Config.cmo_magic_number;
191 let pos_depl = pos_out oc in
192 output_binary_int oc 0;
193 let pos_code = pos_out oc in
194 let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in
195 build_global_target oc targetname members mapping ofs coercion;
196 let pos_debug = pos_out oc in
197 if !Clflags.debug && !events <> [] then
198 output_value oc (List.rev !events);
199 let pos_final = pos_out oc in
202 (fun (name, crc) -> not (List.mem name unit_names))
203 (Bytelink.extract_crc_interfaces()) in
205 { cu_name = targetname;
207 cu_codesize = pos_debug - pos_code;
208 cu_reloc = List.rev !relocs;
209 cu_imports = (targetname, Env.crc_of_unit targetname) :: imports;
210 cu_primitives = !primitives;
211 cu_force_link = !force_link;
212 cu_debug = if pos_final > pos_debug then pos_debug else 0;
213 cu_debugsize = pos_final - pos_debug } in
214 output_value oc compunit;
215 seek_out oc pos_depl;
216 output_binary_int oc pos_final;
222 (* The entry point *)
224 let package_files files targetfile =
228 try find_in_path !Config.load_path f
229 with Not_found -> raise(Error(File_not_found f)))
231 let prefix = chop_extensions targetfile in
232 let targetcmi = prefix ^ ".cmi" in
233 let targetname = String.capitalize(Filename.basename prefix) in
235 let coercion = Typemod.package_units files targetcmi targetname in
236 package_object_files files targetfile targetname coercion
238 remove_file targetfile; raise x
244 let report_error ppf = function
245 Forward_reference(file, ident) ->
246 fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file
247 | Multiple_definition(file, ident) ->
248 fprintf ppf "File %s redefines %s" file (Ident.name ident)
249 | Not_an_object_file file ->
250 fprintf ppf "%s is not a bytecode object file" file
251 | Illegal_renaming(file, id) ->
252 fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
254 | File_not_found file ->
255 fprintf ppf "File %s not found" file