blob: 0ccf3e8f664a134819958d5e8ee28833772c76ce (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Dynamic loading of .cmo files *)
open Emitcode
type linking_error =
Undefined_global of string
| Unavailable_primitive of string
type error =
Not_a_bytecode_file of string
| Inconsistent_import of string
| Unavailable_unit of string
| Unsafe_file
| Linking_error of string * linking_error
| Corrupted_interface of string
exception Error of error
(* Initialize the linker tables and everything *)
let init () =
Symtable.init_toplevel()
(* Check that the object file being loaded has been compiled against
the same interfaces as the program itself. In addition, check that
only authorized compilation units are referenced. *)
let crc_interfaces = (Hashtbl.create 17 : (string, Digest.t) Hashtbl.t)
let check_consistency file_name cu =
List.iter
(fun (name, crc) ->
if name = cu.cu_name then begin
Hashtbl.add crc_interfaces name crc
end else begin
try
let auth_crc = Hashtbl.find crc_interfaces name in
if crc <> auth_crc then
raise(Error(Inconsistent_import name))
with Not_found ->
raise(Error(Unavailable_unit name))
end)
cu.cu_imports
(* Reset the crc_interfaces table *)
let clear_available_units () =
Hashtbl.clear crc_interfaces
(* Initialize the crc_interfaces table with a list of units with fixed CRCs *)
let add_available_units units =
List.iter (fun (unit, crc) -> Hashtbl.add crc_interfaces unit crc) units
(* Read the CRC of an interface from its .cmi file *)
let digest_interface unit loadpath =
let filename = Misc.find_in_path loadpath (String.uncapitalize unit ^ ".cmi") in
let ic = open_in_bin filename in
try
let buffer = String.create (String.length Config.cmi_magic_number) in
really_input ic buffer 0 (String.length Config.cmi_magic_number);
if buffer <> Config.cmi_magic_number then begin
close_in ic;
raise(Error(Corrupted_interface filename))
end;
input_value ic;
let crc =
match input_value ic with
(_, crc) :: _ -> crc
| _ -> raise(Error(Corrupted_interface filename))
in
close_in ic;
crc
with End_of_file | Failure _ ->
close_in ic;
raise(Error(Corrupted_interface filename))
(* Initialize the crc_interfaces table with a list of units.
Their CRCs are read from their interfaces. *)
let add_interfaces units loadpath =
add_available_units
(List.map (fun unit -> (unit, digest_interface unit loadpath)) units)
(* Check whether the object file being loaded was compiled in unsafe mode *)
let unsafe_allowed = ref false
let allow_unsafe_modules b =
unsafe_allowed := b
let check_unsafe_module cu =
if (not !unsafe_allowed) & cu.cu_primitives <> []
then raise(Error(Unsafe_file))
(* Load in-core and execute a bytecode object file *)
let load_compunit ic file_name compunit =
check_consistency file_name compunit;
check_unsafe_module compunit;
seek_in ic compunit.cu_pos;
let code_size = compunit.cu_codesize + 8 in
let code = Meta.static_alloc code_size in
unsafe_really_input ic code 0 compunit.cu_codesize;
String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
String.unsafe_set code (compunit.cu_codesize + 1) '\000';
String.unsafe_set code (compunit.cu_codesize + 2) '\000';
String.unsafe_set code (compunit.cu_codesize + 3) '\000';
String.unsafe_set code (compunit.cu_codesize + 4) '\001';
String.unsafe_set code (compunit.cu_codesize + 5) '\000';
String.unsafe_set code (compunit.cu_codesize + 6) '\000';
String.unsafe_set code (compunit.cu_codesize + 7) '\000';
let initial_symtable = Symtable.current_state() in
begin try
Symtable.patch_object code compunit.cu_reloc;
Symtable.update_global_table()
with Symtable.Error error ->
let new_error =
match error with
Symtable.Undefined_global s -> Undefined_global s
| Symtable.Unavailable_primitive s -> Unavailable_primitive s
| _ -> assert false in
raise(Error(Linking_error (file_name, new_error)))
end;
begin try
ignore((Meta.reify_bytecode code code_size) ())
with exn ->
Symtable.restore_state initial_symtable;
raise exn
end
let loadfile file_name =
let ic = open_in_bin file_name in
try
let buffer = String.create (String.length Config.cmo_magic_number) in
really_input ic buffer 0 (String.length Config.cmo_magic_number);
if buffer = Config.cmo_magic_number then begin
let compunit_pos = input_binary_int ic in (* Go to descriptor *)
seek_in ic compunit_pos;
load_compunit ic file_name (input_value ic : compilation_unit)
end else
if buffer = Config.cma_magic_number then begin
let toc_pos = input_binary_int ic in (* Go to table of contents *)
seek_in ic toc_pos;
List.iter (load_compunit ic file_name)
(input_value ic : compilation_unit list)
end else
raise(Error(Not_a_bytecode_file file_name));
close_in ic
with exc ->
close_in ic; raise exc
let loadfile_private file_name =
let initial_symtable = Symtable.current_state() in
try
loadfile file_name;
Symtable.hide_additions initial_symtable
with exn ->
Symtable.hide_additions initial_symtable;
raise exn
(* Error report *)
let error_message = function
Not_a_bytecode_file name ->
name ^ " is not a bytecode object file"
| Inconsistent_import name ->
"interface mismatch on " ^ name
| Unavailable_unit name ->
"no implementation available for " ^ name
| Unsafe_file ->
"this object file uses unsafe features"
| Linking_error (name, Undefined_global s) ->
"error while linking " ^ name ^ ".\n" ^
"Reference to undefined global `" ^ s ^ "'"
| Linking_error (name, Unavailable_primitive s) ->
"error while linking " ^ name ^ ".\n" ^
"The external function `" ^ s ^ "' is not available"
| Corrupted_interface name ->
"corrupted interface file " ^ name
|
