1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 2002 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* "Package" a set of .cmo files into one .cmo file having the
17 original compilation units as sub-modules. *)
18
19 open Misc
20 open Instruct
21 open Cmo_format
22 module String = Misc.Stdlib.String
23
24 type error =
25 Forward_reference of string * Ident.t
26 | Multiple_definition of string * Ident.t
27 | Not_an_object_file of string
28 | Illegal_renaming of string * string * string
29 | File_not_found of string
30
31 exception Error of error
32
33 (* References accumulating information on the .cmo files *)
34
35 let relocs = ref ([] : (reloc_info * int) list)
36 let events = ref ([] : debug_event list)
37 let debug_dirs = ref String.Set.empty
38 let primitives = ref ([] : string list)
39 let force_link = ref false
40
41 (* Record a relocation. Update its offset, and rename GETGLOBAL and
42 SETGLOBAL relocations that correspond to one of the units being
43 consolidated. *)
44
45 let rename_relocation packagename objfile mapping defined base (rel, ofs) =
46 let rel' =
47 match rel with
48 Reloc_getglobal id ->
49 begin try
50 let id' = List.assoc id mapping in
51 if List.mem id defined
52 then Reloc_getglobal id'
53 else raise(Error(Forward_reference(objfile, id)))
54 with Not_found ->
55 (* PR#5276: unique-ize dotted global names, which appear
56 if one of the units being consolidated is itself a packed
57 module. *)
58 let name = Ident.name id in
59 if String.contains name '.' then
60 Reloc_getglobal (Ident.create_persistent (packagename ^ "." ^ name))
61 else
62 rel
63 end
64 | Reloc_setglobal id ->
65 begin try
66 let id' = List.assoc id mapping in
67 if List.mem id defined
68 then raise(Error(Multiple_definition(objfile, id)))
69 else Reloc_setglobal id'
70 with Not_found ->
71 (* PR#5276, as above *)
72 let name = Ident.name id in
73 if String.contains name '.' then
74 Reloc_setglobal (Ident.create_persistent (packagename ^ "." ^ name))
75 else
76 rel
77 end
78 | _ ->
79 rel in
80 relocs := (rel', base + ofs) :: !relocs
81
82 (* Record and relocate a debugging event *)
83
84 let relocate_debug base prefix subst ev =
85 let ev' = { ev with ev_pos = base + ev.ev_pos;
86 ev_module = prefix ^ "." ^ ev.ev_module;
87 ev_typsubst = Subst.compose ev.ev_typsubst subst } in
88 events := ev' :: !events
89
90 (* Read the unit information from a .cmo file. *)
91
92 type pack_member_kind = PM_intf | PM_impl of compilation_unit
93
94 type pack_member =
95 { pm_file: string;
96 pm_name: string;
97 pm_kind: pack_member_kind }
98
99 let read_member_info file = (
100 let name =
101 String.capitalize_ascii(Filename.basename(chop_extensions file)) in
102 let kind =
103 (* PR#7479: make sure it is either a .cmi or a .cmo *)
104 if Filename.check_suffix file ".cmi" then
105 PM_intf
106 else begin
107 let ic = open_in_bin file in
108 try
109 let buffer =
110 really_input_string ic (String.length Config.cmo_magic_number)
111 in
112 if buffer <> Config.cmo_magic_number then
113 raise(Error(Not_an_object_file file));
114 let compunit_pos = input_binary_int ic in
115 seek_in ic compunit_pos;
116 let compunit = (input_value ic : compilation_unit) in
117 if compunit.cu_name <> name
118 then raise(Error(Illegal_renaming(name, file, compunit.cu_name)));
119 close_in ic;
120 PM_impl compunit
121 with x ->
122 close_in ic;
123 raise x
124 end in
125 { pm_file = file; pm_name = name; pm_kind = kind }
126 )
127
128 (* Read the bytecode from a .cmo file.
129 Write bytecode to channel [oc].
130 Rename globals as indicated by [mapping] in reloc info.
131 Accumulate relocs, debug info, etc.
132 Return size of bytecode. *)
133
134 let rename_append_bytecode packagename oc mapping defined ofs prefix subst
135 objfile compunit =
136 let ic = open_in_bin objfile in
137 try
138 Bytelink.check_consistency objfile compunit;
139 List.iter
140 (rename_relocation packagename objfile mapping defined ofs)
141 compunit.cu_reloc;
142 primitives := compunit.cu_primitives @ !primitives;
143 if compunit.cu_force_link then force_link := true;
144 seek_in ic compunit.cu_pos;
145 Misc.copy_file_chunk ic oc compunit.cu_codesize;
146 if !Clflags.debug && compunit.cu_debug > 0 then begin
147 seek_in ic compunit.cu_debug;
148 List.iter (relocate_debug ofs prefix subst) (input_value ic);
149 debug_dirs := List.fold_left
150 (fun s e -> String.Set.add e s)
151 !debug_dirs
152 (input_value ic);
153 end;
154 close_in ic;
155 compunit.cu_codesize
156 with x ->
157 close_in ic;
158 raise x
159
160 (* Same, for a list of .cmo and .cmi files.
161 Return total size of bytecode. *)
162
163 let rec rename_append_bytecode_list packagename oc mapping defined ofs
164 prefix subst =
165 function
166 [] ->
167 ofs
168 | m :: rem ->
169 match m.pm_kind with
170 | PM_intf ->
171 rename_append_bytecode_list packagename oc mapping defined ofs
172 prefix subst rem
173 | PM_impl compunit ->
174 let size =
175 rename_append_bytecode packagename oc mapping defined ofs
176 prefix subst m.pm_file compunit in
177 let id = Ident.create_persistent m.pm_name in
178 let root = Path.Pident (Ident.create_persistent prefix) in
179 rename_append_bytecode_list packagename oc mapping (id :: defined)
180 (ofs + size) prefix
181 (Subst.add_module id (Path.Pdot (root, Ident.name id))
182 subst)
183 rem
184
185 (* Generate the code that builds the tuple representing the package module *)
186
187 let build_global_target ~ppf_dump oc target_name members mapping pos coercion =
188 let components =
189 List.map2
190 (fun m (_id1, id2) ->
191 match m.pm_kind with
192 | PM_intf -> None
193 | PM_impl _ -> Some id2)
194 members mapping in
195 let lam =
196 Translmod.transl_package
197 components (Ident.create_persistent target_name) coercion in
198 let lam = Simplif.simplify_lambda lam in
199 if !Clflags.dump_lambda then
200 Format.fprintf ppf_dump "%a@." Printlambda.lambda lam;
201 let instrs =
202 Bytegen.compile_implementation target_name lam in
203 let rel =
204 Emitcode.to_packed_file oc instrs in
205 relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs
206
207 (* Build the .cmo file obtained by packaging the given .cmo files. *)
208
209 let package_object_files ~ppf_dump files targetfile targetname coercion =
210 let members =
211 map_left_right read_member_info files in
212 let required_globals =
213 List.fold_right (fun compunit required_globals -> match compunit with
214 | { pm_kind = PM_intf } ->
215 required_globals
216 | { pm_kind = PM_impl { cu_required_globals; cu_reloc } } ->
217 let remove_required (rel, _pos) required_globals =
218 match rel with
219 Reloc_setglobal id ->
220 Ident.Set.remove id required_globals
221 | _ ->
222 required_globals
223 in
224 let required_globals =
225 List.fold_right remove_required cu_reloc required_globals
226 in
227 List.fold_right Ident.Set.add cu_required_globals required_globals)
228 members Ident.Set.empty
229 in
230 let unit_names =
231 List.map (fun m -> m.pm_name) members in
232 let mapping =
233 List.map
234 (fun name ->
235 (Ident.create_persistent name,
236 Ident.create_persistent(targetname ^ "." ^ name)))
237 unit_names in
238 let oc = open_out_bin targetfile in
239 try
240 output_string oc Config.cmo_magic_number;
241 let pos_depl = pos_out oc in
242 output_binary_int oc 0;
243 let pos_code = pos_out oc in
244 let ofs = rename_append_bytecode_list targetname oc mapping [] 0
245 targetname Subst.identity members in
246 build_global_target ~ppf_dump oc targetname members mapping ofs coercion;
247 let pos_debug = pos_out oc in
248 if !Clflags.debug && !events <> [] then begin
249 output_value oc (List.rev !events);
250 output_value oc (String.Set.elements !debug_dirs);
251 end;
252 let pos_final = pos_out oc in
253 let imports =
254 List.filter
255 (fun (name, _crc) -> not (List.mem name unit_names))
256 (Bytelink.extract_crc_interfaces()) in
257 let compunit =
258 { cu_name = targetname;
259 cu_pos = pos_code;
260 cu_codesize = pos_debug - pos_code;
261 cu_reloc = List.rev !relocs;
262 cu_imports =
263 (targetname, Some (Env.crc_of_unit targetname)) :: imports;
264 cu_primitives = !primitives;
265 cu_required_globals = Ident.Set.elements required_globals;
266 cu_force_link = !force_link;
267 cu_debug = if pos_final > pos_debug then pos_debug else 0;
268 cu_debugsize = pos_final - pos_debug } in
269 Emitcode.marshal_to_channel_with_possibly_32bit_compat
270 ~filename:targetfile ~kind:"bytecode unit"
271 oc compunit;
272 seek_out oc pos_depl;
273 output_binary_int oc pos_final;
274 close_out oc
275 with x ->
276 close_out oc;
277 raise x
278
279 (* The entry point *)
280
281 let package_files ~ppf_dump initial_env files targetfile =
282 let files =
283 List.map
284 (fun f ->
285 try Load_path.find f
286 with Not_found -> raise(Error(File_not_found f)))
287 files in
288 let prefix = chop_extensions targetfile in
289 let targetcmi = prefix ^ ".cmi" in
290 let targetname = String.capitalize_ascii(Filename.basename prefix) in
291 Misc.try_finally (fun () ->
292 let coercion =
293 Typemod.package_units initial_env files targetcmi targetname in
294 package_object_files ~ppf_dump files targetfile targetname coercion
295 )
296 ~exceptionally:(fun () -> remove_file targetfile)
297
298 (* Error report *)
299
300 open Format
301
302 let report_error ppf = function
303 Forward_reference(file, ident) ->
304 fprintf ppf "Forward reference to %s in file %a" (Ident.name ident)
305 Location.print_filename file
306 | Multiple_definition(file, ident) ->
307 fprintf ppf "File %a redefines %s"
308 Location.print_filename file
309 (Ident.name ident)
310 | Not_an_object_file file ->
311 fprintf ppf "%a is not a bytecode object file"
312 Location.print_filename file
313 | Illegal_renaming(name, file, id) ->
314 fprintf ppf "Wrong file naming: %a@ contains the code for\
315 @ %s when %s was expected"
316 Location.print_filename file name id
317 | File_not_found file ->
318 fprintf ppf "File %s not found" file
319
320 let () =
321 Location.register_error_of_exn
322 (function
323 | Error err -> Some (Location.error_of_printer_file report_error err)
324 | _ -> None
325 )
326
327 let reset () =
328 relocs := [];
329 events := [];
330 primitives := [];
331 force_link := false
332