1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 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 [@@@ocaml.warning "-40"]
17
18 (* To assign numbers to globals and primitives *)
19
20 open Misc
21 open Asttypes
22 open Lambda
23 open Cmo_format
24
25 module String = Misc.Stdlib.String
26
27 (* Functions for batch linking *)
28
29 type error =
30 Undefined_global of string
31 | Unavailable_primitive of string
32 | Wrong_vm of string
33 | Uninitialized_global of string
34
35 exception Error of error
36
37 module Num_tbl (M : Map.S) = struct
38
39 type t = {
40 cnt: int; (* The next number *)
41 tbl: int M.t ; (* The table of already numbered objects *)
42 }
43
44 let empty = { cnt = 0; tbl = M.empty }
45
46 let find nt key =
47 M.find key nt.tbl
48
49 let enter nt key =
50 let n = !nt.cnt in
51 nt := { cnt = n + 1; tbl = M.add key n !nt.tbl };
52 n
53
54 let incr nt =
55 let n = !nt.cnt in
56 nt := { cnt = n + 1; tbl = !nt.tbl };
57 n
58
59 end
60 module GlobalMap = Num_tbl(Ident.Map)
61 module PrimMap = Num_tbl(Misc.Stdlib.String.Map)
62
63 (* Global variables *)
64
65 let global_table = ref GlobalMap.empty
66 and literal_table = ref([] : (int * structured_constant) list)
67
68 let is_global_defined id =
69 Ident.Map.mem id (!global_table).tbl
70
71 let slot_for_getglobal id =
72 try
73 GlobalMap.find !global_table id
74 with Not_found ->
75 raise(Error(Undefined_global(Ident.name id)))
76
77 let slot_for_setglobal id =
78 GlobalMap.enter global_table id
79
80 let slot_for_literal cst =
81 let n = GlobalMap.incr global_table in
82 literal_table := (n, cst) :: !literal_table;
83 n
84
85 (* The C primitives *)
86
87 let c_prim_table = ref PrimMap.empty
88
89 let set_prim_table name =
90 ignore(PrimMap.enter c_prim_table name)
91
92 let of_prim name =
93 try
94 PrimMap.find !c_prim_table name
95 with Not_found ->
96 if !Clflags.custom_runtime || Config.host <> Config.target
97 || !Clflags.no_check_prims
98 then
99 PrimMap.enter c_prim_table name
100 else begin
101 let symb =
102 try Dll.find_primitive name
103 with Not_found -> raise(Error(Unavailable_primitive name)) in
104 let num = PrimMap.enter c_prim_table name in
105 Dll.synchronize_primitive num symb;
106 num
107 end
108
109 let require_primitive name =
110 if name.[0] <> '%' then ignore(of_prim name)
111
112 let all_primitives () =
113 let prim = Array.make !c_prim_table.cnt "" in
114 String.Map.iter (fun name number -> prim.(number) <- name) !c_prim_table.tbl;
115 prim
116
117 let data_primitive_names () =
118 let prim = all_primitives() in
119 let b = Buffer.create 512 in
120 for i = 0 to Array.length prim - 1 do
121 Buffer.add_string b prim.(i); Buffer.add_char b '\000'
122 done;
123 Buffer.contents b
124
125 let output_primitive_names outchan =
126 output_string outchan (data_primitive_names())
127
128 open Printf
129
130 let output_primitive_table outchan =
131 let prim = all_primitives() in
132 for i = 0 to Array.length prim - 1 do
133 fprintf outchan "extern value %s();\n" prim.(i)
134 done;
135 fprintf outchan "typedef value (*primitive)();\n";
136 fprintf outchan "primitive caml_builtin_cprim[] = {\n";
137 for i = 0 to Array.length prim - 1 do
138 fprintf outchan " %s,\n" prim.(i)
139 done;
140 fprintf outchan " (primitive) 0 };\n";
141 fprintf outchan "const char * caml_names_of_builtin_cprim[] = {\n";
142 for i = 0 to Array.length prim - 1 do
143 fprintf outchan " \"%s\",\n" prim.(i)
144 done;
145 fprintf outchan " (char *) 0 };\n"
146
147 (* Initialization for batch linking *)
148
149 let init () =
150 (* Enter the predefined exceptions *)
151 Array.iteri
152 (fun i name ->
153 let id =
154 try List.assoc name Predef.builtin_values
155 with Not_found -> fatal_error "Symtable.init" in
156 let c = slot_for_setglobal id in
157 let cst = Const_block(Obj.object_tag,
158 [Const_base(Const_string (name, None));
159 Const_base(Const_int (-i-1))
160 ])
161 in
162 literal_table := (c, cst) :: !literal_table)
163 Runtimedef.builtin_exceptions;
164 (* Initialize the known C primitives *)
165 let set_prim_table_from_file primfile =
166 let ic = open_in primfile in
167 Misc.try_finally
168 ~always:(fun () -> close_in ic)
169 (fun () ->
170 try
171 while true do
172 set_prim_table (input_line ic)
173 done
174 with End_of_file -> ()
175 )
176 in
177 if String.length !Clflags.use_prims > 0 then
178 set_prim_table_from_file !Clflags.use_prims
179 else if String.length !Clflags.use_runtime > 0 then begin
180 let primfile = Filename.temp_file "camlprims" "" in
181 Misc.try_finally
182 ~always:(fun () -> remove_file primfile)
183 (fun () ->
184 if Sys.command(Printf.sprintf "%s -p > %s"
185 !Clflags.use_runtime primfile) <> 0
186 then raise(Error(Wrong_vm !Clflags.use_runtime));
187 set_prim_table_from_file primfile
188 )
189 end else begin
190 Array.iter set_prim_table Runtimedef.builtin_primitives
191 end
192
193 (* Relocate a block of object bytecode *)
194
195 let patch_int buff pos n =
196 LongString.set buff pos (Char.unsafe_chr n);
197 LongString.set buff (pos + 1) (Char.unsafe_chr (n asr 8));
198 LongString.set buff (pos + 2) (Char.unsafe_chr (n asr 16));
199 LongString.set buff (pos + 3) (Char.unsafe_chr (n asr 24))
200
201 let patch_object buff patchlist =
202 List.iter
203 (function
204 (Reloc_literal sc, pos) ->
205 patch_int buff pos (slot_for_literal sc)
206 | (Reloc_getglobal id, pos) ->
207 patch_int buff pos (slot_for_getglobal id)
208 | (Reloc_setglobal id, pos) ->
209 patch_int buff pos (slot_for_setglobal id)
210 | (Reloc_primitive name, pos) ->
211 patch_int buff pos (of_prim name))
212 patchlist
213
214 (* Translate structured constants *)
215
216 let rec transl_const = function
217 Const_base(Const_int i) -> Obj.repr i
218 | Const_base(Const_char c) -> Obj.repr c
219 | Const_base(Const_string (s, _)) -> Obj.repr s
220 | Const_base(Const_float f) -> Obj.repr (float_of_string f)
221 | Const_base(Const_int32 i) -> Obj.repr i
222 | Const_base(Const_int64 i) -> Obj.repr i
223 | Const_base(Const_nativeint i) -> Obj.repr i
224 | Const_pointer i -> Obj.repr i
225 | Const_immstring s -> Obj.repr s
226 | Const_block(tag, fields) ->
227 let block = Obj.new_block tag (List.length fields) in
228 let pos = ref 0 in
229 List.iter
230 (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
231 fields;
232 block
233 | Const_float_array fields ->
234 let res = Array.Floatarray.create (List.length fields) in
235 List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
236 fields;
237 Obj.repr res
238
239 (* Build the initial table of globals *)
240
241 let initial_global_table () =
242 let glob = Array.make !global_table.cnt (Obj.repr 0) in
243 List.iter
244 (fun (slot, cst) -> glob.(slot) <- transl_const cst)
245 !literal_table;
246 literal_table := [];
247 glob
248
249 (* Save the table of globals *)
250
251 let output_global_map oc =
252 output_value oc !global_table
253
254 let data_global_map () =
255 Obj.repr !global_table
256
257 (* Functions for toplevel use *)
258
259 (* Update the in-core table of globals *)
260
261 let update_global_table () =
262 let ng = !global_table.cnt in
263 if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng;
264 let glob = Meta.global_data() in
265 List.iter
266 (fun (slot, cst) -> glob.(slot) <- transl_const cst)
267 !literal_table;
268 literal_table := []
269
270 (* Recover data for toplevel initialization. Data can come either from
271 executable file (normal case) or from linked-in data (-output-obj). *)
272
273 type section_reader = {
274 read_string: string -> string;
275 read_struct: string -> Obj.t;
276 close_reader: unit -> unit
277 }
278
279 let read_sections () =
280 try
281 let sections = Meta.get_section_table () in
282 { read_string =
283 (fun name -> (Obj.magic(List.assoc name sections) : string));
284 read_struct =
285 (fun name -> List.assoc name sections);
286 close_reader =
287 (fun () -> ()) }
288 with Not_found ->
289 let ic = open_in_bin Sys.executable_name in
290 Bytesections.read_toc ic;
291 { read_string = Bytesections.read_section_string ic;
292 read_struct = Bytesections.read_section_struct ic;
293 close_reader = fun () -> close_in ic }
294
295 (* Initialize the linker for toplevel use *)
296
297 let init_toplevel () =
298 try
299 let sect = read_sections () in
300 (* Locations of globals *)
301 global_table := (Obj.magic (sect.read_struct "SYMB") : GlobalMap.t);
302 (* Primitives *)
303 let prims = sect.read_string "PRIM" in
304 c_prim_table := PrimMap.empty;
305 let pos = ref 0 in
306 while !pos < String.length prims do
307 let i = String.index_from prims !pos '\000' in
308 set_prim_table (String.sub prims !pos (i - !pos));
309 pos := i + 1
310 done;
311 (* DLL initialization *)
312 let dllpath = try sect.read_string "DLPT" with Not_found -> "" in
313 Dll.init_toplevel dllpath;
314 (* Recover CRC infos for interfaces *)
315 let crcintfs =
316 try
317 (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list)
318 with Not_found -> [] in
319 (* Done *)
320 sect.close_reader();
321 crcintfs
322 with Bytesections.Bad_magic_number | Not_found | Failure _ ->
323 fatal_error "Toplevel bytecode executable is corrupted"
324
325 (* Find the value of a global identifier *)
326
327 let get_global_position id = slot_for_getglobal id
328
329 let get_global_value id =
330 (Meta.global_data()).(slot_for_getglobal id)
331 let assign_global_value id v =
332 (Meta.global_data()).(slot_for_getglobal id) <- v
333
334 (* Check that all globals referenced in the given patch list
335 have been initialized already *)
336
337 let defined_globals patchlist =
338 List.fold_left (fun accu rel ->
339 match rel with
340 | (Reloc_setglobal id, _pos) -> id :: accu
341 | _ -> accu)
342 []
343 patchlist
344
345 let required_globals patchlist =
346 List.fold_left (fun accu rel ->
347 match rel with
348 | (Reloc_getglobal id, _pos) -> id :: accu
349 | _ -> accu)
350 []
351 patchlist
352
353 let check_global_initialized patchlist =
354 (* First determine the globals we will define *)
355 let defined_globals = defined_globals patchlist in
356 (* Then check that all referenced, not defined globals have a value *)
357 let check_reference = function
358 (Reloc_getglobal id, _pos) ->
359 if not (List.mem id defined_globals)
360 && Obj.is_int (get_global_value id)
361 then raise (Error(Uninitialized_global(Ident.name id)))
362 | _ -> () in
363 List.iter check_reference patchlist
364
365 (* Save and restore the current state *)
366
367 type global_map = GlobalMap.t
368
369 let current_state () = !global_table
370
371 let restore_state st = global_table := st
372
373 let hide_additions (st : global_map) =
374 if st.cnt > !global_table.cnt then
375 fatal_error "Symtable.hide_additions";
376 global_table :=
377 {GlobalMap.
378 cnt = !global_table.cnt;
379 tbl = st.tbl }
380
381 (* "Filter" the global map according to some predicate.
382 Used to expunge the global map for the toplevel. *)
383
384 let filter_global_map p (gmap : global_map) =
385 let newtbl = ref Ident.Map.empty in
386 Ident.Map.iter
387 (fun id num -> if p id then newtbl := Ident.Map.add id num !newtbl)
388 gmap.tbl;
389 {GlobalMap. cnt = gmap.cnt; tbl = !newtbl}
390
391 let iter_global_map f (gmap : global_map) =
392 Ident.Map.iter f gmap.tbl
393
394 let is_defined_in_global_map (gmap : global_map) id =
395 Ident.Map.mem id gmap.tbl
396
397 let empty_global_map = GlobalMap.empty
398
399 (* Error report *)
400
401 open Format
402
403 let report_error ppf = function
404 | Undefined_global s ->
405 fprintf ppf "Reference to undefined global `%s'" s
406 | Unavailable_primitive s ->
407 fprintf ppf "The external function `%s' is not available" s
408 | Wrong_vm s ->
409 fprintf ppf "Cannot find or execute the runtime system %s" s
410 | Uninitialized_global s ->
411 fprintf ppf "The value of the global `%s' is not yet computed" s
412
413 let () =
414 Location.register_error_of_exn
415 (function
416 | Error err -> Some (Location.error_of_printer_file report_error err)
417 | _ -> None
418 )
419
420 let reset () =
421 global_table := GlobalMap.empty;
422 literal_table := [];
423 c_prim_table := PrimMap.empty
424