]> rtime.felk.cvut.cz Git - l4.git/blob - l4/pkg/ocaml/contrib/bytecomp/bytepackager.ml
update
[l4.git] / l4 / pkg / ocaml / contrib / bytecomp / bytepackager.ml
1 (***********************************************************************)
2 (*                                                                     *)
3 (*                           Objective Caml                            *)
4 (*                                                                     *)
5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
6 (*                                                                     *)
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.               *)
10 (*                                                                     *)
11 (***********************************************************************)
12
13 (* $Id: bytepackager.ml 9221 2009-04-02 09:06:33Z xclerc $ *)
14
15 (* "Package" a set of .cmo files into one .cmo file having the
16    original compilation units as sub-modules. *)
17
18 open Misc
19 open Instruct
20 open Cmo_format
21
22 type error =
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
28
29 exception Error of error
30
31 (* References accumulating informations on the .cmo files *)
32
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
37
38 (* Record a relocation.  Update its offset, and rename GETGLOBAL and
39    SETGLOBAL relocations that correspond to one of the units being
40    consolidated. *)
41
42 let rename_relocation objfile mapping defined base (rel, ofs) =
43   let rel' =
44     match rel with
45       Reloc_getglobal id ->
46         begin try
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)))
51         with Not_found ->
52           rel
53         end
54     | Reloc_setglobal id ->
55         begin try
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'
60         with Not_found ->
61           rel
62         end
63     | _ ->
64         rel in
65   relocs := (rel', base + ofs) :: !relocs
66
67 (* Record and relocate a debugging event *)
68
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
74
75 (* Read the unit information from a .cmo file. *)
76
77 type pack_member_kind = PM_intf | PM_impl of compilation_unit
78
79 type pack_member =
80   { pm_file: string;
81     pm_name: string;
82     pm_kind: pack_member_kind }
83
84 let read_member_info file =
85   let name =
86     String.capitalize(Filename.basename(chop_extensions file)) in
87   let kind =
88     if Filename.check_suffix file ".cmo" then begin
89     let ic = open_in_bin file in
90     try
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)));
100       close_in ic;
101       PM_impl compunit
102     with x ->
103       close_in ic;
104       raise x
105     end else
106       PM_intf in
107   { pm_file = file; pm_name = name; pm_kind = kind }
108
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. *)
114
115 let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit =
116   let ic = open_in_bin objfile in
117   try
118     Bytelink.check_consistency objfile compunit;
119     List.iter
120       (rename_relocation objfile mapping defined ofs)
121       compunit.cu_reloc;
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);
129     end;
130     close_in ic;
131     compunit.cu_codesize
132   with x ->
133     close_in ic;
134     raise x
135
136 (* Same, for a list of .cmo and .cmi files.
137    Return total size of bytecode. *)
138
139 let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function
140     [] ->
141       ofs
142   | m :: rem ->
143       match m.pm_kind with
144       | PM_intf ->
145           rename_append_bytecode_list oc mapping defined ofs prefix subst rem
146       | PM_impl compunit ->
147           let size =
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
155
156 (* Generate the code that builds the tuple representing the package module *)
157
158 let build_global_target oc target_name members mapping pos coercion =
159   let components =
160     List.map2
161       (fun m (id1, id2) ->
162         match m.pm_kind with
163         | PM_intf -> None
164         | PM_impl _ -> Some id2)
165       members mapping in
166   let lam =
167     Translmod.transl_package
168       components (Ident.create_persistent target_name) coercion in
169   let instrs =
170     Bytegen.compile_implementation target_name lam in
171   let rel =
172     Emitcode.to_packed_file oc instrs in
173   relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs
174
175 (* Build the .cmo file obtained by packaging the given .cmo files. *)
176
177 let package_object_files files targetfile targetname coercion =
178   let members =
179     map_left_right read_member_info files in
180   let unit_names =
181     List.map (fun m -> m.pm_name) members in
182   let mapping =
183     List.map
184       (fun name ->
185           (Ident.create_persistent name,
186            Ident.create_persistent(targetname ^ "." ^ name)))
187       unit_names in
188   let oc = open_out_bin targetfile in
189   try
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
200     let imports =
201       List.filter
202         (fun (name, crc) -> not (List.mem name unit_names))
203         (Bytelink.extract_crc_interfaces()) in
204     let compunit =
205       { cu_name = targetname;
206         cu_pos = pos_code;
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;
217     close_out oc
218   with x ->
219     close_out oc;
220     raise x
221
222 (* The entry point *)
223
224 let package_files files targetfile =
225   let files =
226     List.map
227       (fun f ->
228         try find_in_path !Config.load_path f
229         with Not_found -> raise(Error(File_not_found f)))
230       files in
231   let prefix = chop_extensions targetfile in
232   let targetcmi = prefix ^ ".cmi" in
233   let targetname = String.capitalize(Filename.basename prefix) in
234   try
235     let coercion = Typemod.package_units files targetcmi targetname in
236     package_object_files files targetfile targetname coercion
237   with x ->
238     remove_file targetfile; raise x
239
240 (* Error report *)
241
242 open Format
243
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"
253         file id
254   | File_not_found file ->
255       fprintf ppf "File %s not found" file