1 #2 "otherlibs/dynlink/dynlink_common.ml"
2 (**************************************************************************)
3 (* *)
4 (* OCaml *)
5 (* *)
6 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
7 (* Mark Shinwell and Leo White, Jane Street Europe *)
8 (* *)
9 (* Copyright 1996 Institut National de Recherche en Informatique et *)
10 (* en Automatique. *)
11 (* Copyright 2017--2019 Jane Street Group LLC *)
12 (* *)
13 (* All rights reserved. This file is distributed under the terms of *)
14 (* the GNU Lesser General Public License version 2.1, with the *)
15 (* special exception on linking described in the file LICENSE. *)
16 (* *)
17 (**************************************************************************)
18
19 [@@@ocaml.warning "+a-4-30-40-41-42"]
20
21 open! Dynlink_compilerlibs
22
23 module String = struct
24 include Misc.Stdlib.String
25
26 module Map = struct
27 include Map
28
29 let keys t =
30 fold (fun key _data keys -> Set.add key keys) t Set.empty
31 end
32 end
33
34 module Make (P : Dynlink_platform_intf.S) = struct
35 module DT = Dynlink_types
36 module UH = P.Unit_header
37
38 type interface_dep =
39 | Name (* the only use of the interface can be via a module alias *)
40 | Contents of Digest.t
41
42 type implem = Digest.t option * DT.filename * DT.implem_state
43
44 module State = struct
45 type t = {
46 ifaces : (interface_dep * DT.filename) String.Map.t;
47 (* Interfaces that have been depended upon. *)
48 implems : implem String.Map.t;
49 (* Implementations that exist in the main program or have been
50 dynamically loaded. *)
51 defined_symbols : String.Set.t;
52 (* Symbols corresponding to compilation units or packed modules (cf.
53 [Asmpackager.build_package_cmx]). Used as a sanity check. *)
54 allowed_units : String.Set.t;
55 (* Units that are allowed to be referenced by a subsequently-loaded
56 dynamic library. *)
57 main_program_units : String.Set.t;
58 (* Units forming part of the main program (i.e. not dynamically
59 linked). *)
60 public_dynamically_loaded_units : String.Set.t;
61 (* All units that have been dynamically linked, not including those that
62 were privately loaded. *)
63 }
64
65 let invariant t =
66 let ifaces = String.Map.keys t.ifaces in
67 let implems = String.Map.keys t.implems in
68 assert (String.Set.subset implems ifaces);
69 assert (String.Set.subset t.main_program_units ifaces);
70 assert (String.Set.subset t.main_program_units implems);
71 assert (String.Set.subset t.public_dynamically_loaded_units ifaces);
72 assert (String.Set.subset t.public_dynamically_loaded_units implems)
73
74 let empty = {
75 ifaces = String.Map.empty;
76 implems = String.Map.empty;
77 defined_symbols = String.Set.empty;
78 allowed_units = String.Set.empty;
79 main_program_units = String.Set.empty;
80 public_dynamically_loaded_units = String.Set.empty;
81 }
82 end
83
84 let global_state = ref State.empty
85
86 let inited = ref false
87
88 let unsafe_allowed = ref false
89
90 let allow_unsafe_modules b =
91 unsafe_allowed := b
92
93 let check_symbols_disjoint ~descr syms1 syms2 =
94 let exe = Sys.executable_name in
95 let overlap = String.Set.inter syms1 syms2 in
96 if not (String.Set.is_empty overlap) then begin
97 let msg =
98 Format.asprintf "%s: symbols multiply-defined %s: %a"
99 exe (Lazy.force descr)
100 (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
101 Format.pp_print_string)
102 (String.Set.elements overlap)
103 in
104 failwith msg
105 end
106
107 let default_available_units () =
108 let exe = Sys.executable_name in
109 let ifaces, implems, defined_symbols =
110 P.fold_initial_units
111 ~init:(String.Map.empty, String.Map.empty, String.Set.empty)
112 ~f:(fun (ifaces, implems, defined_symbols)
113 ~comp_unit ~interface ~implementation
114 ~defined_symbols:defined_symbols_this_unit ->
115 let ifaces =
116 match interface with
117 | None -> String.Map.add comp_unit (Name, exe) ifaces
118 | Some crc -> String.Map.add comp_unit (Contents crc, exe) ifaces
119 in
120 let implems =
121 match implementation with
122 | None -> implems
123 | Some (crc, state) ->
124 String.Map.add comp_unit (crc, exe, state) implems
125 in
126 let defined_symbols_this_unit =
127 String.Set.of_list defined_symbols_this_unit
128 in
129 check_symbols_disjoint ~descr:(lazy "in the executable file")
130 defined_symbols_this_unit defined_symbols;
131 let defined_symbols =
132 String.Set.union defined_symbols_this_unit defined_symbols
133 in
134 ifaces, implems, defined_symbols)
135 in
136 let main_program_units = String.Map.keys implems in
137 let state : State.t =
138 { ifaces;
139 implems;
140 defined_symbols;
141 allowed_units = main_program_units;
142 main_program_units;
143 public_dynamically_loaded_units = String.Set.empty;
144 }
145 in
146 global_state := state
147
148 let init () =
149 if not !inited then begin
150 P.init ();
151 default_available_units ();
152 inited := true
153 end
154
155 let set_loaded_implem filename ui implems =
156 String.Map.add (UH.name ui) (UH.crc ui, filename, DT.Loaded) implems
157
158 let set_loaded filename ui (state : State.t) =
159 { state with implems = set_loaded_implem filename ui state.implems }
160
161 let check_interface_imports filename ui ifaces =
162 List.fold_left (fun ifaces (name, crc) ->
163 match String.Map.find name ifaces with
164 | exception Not_found -> begin
165 match crc with
166 | None -> String.Map.add name (Name, filename) ifaces
167 | Some crc -> String.Map.add name (Contents crc, filename) ifaces
168 end
169 | old_crc, _old_src ->
170 match old_crc, crc with
171 | (Name | Contents _), None -> ifaces
172 | Name, Some crc ->
173 String.Map.add name (Contents crc, filename) ifaces
174 | Contents old_crc, Some crc ->
175 if old_crc <> crc then raise (DT.Error (Inconsistent_import name))
176 else ifaces)
177 ifaces
178 (UH.interface_imports ui)
179
180 let check_implementation_imports ~allowed_units filename ui implems =
181 List.iter (fun (name, crc) ->
182 if not (String.Set.mem name allowed_units) then begin
183 raise (DT.Error (Unavailable_unit name))
184 end;
185 match String.Map.find name implems with
186 | exception Not_found -> raise (DT.Error (Unavailable_unit name))
187 | ((old_crc, _old_src, unit_state) : implem) ->
188 begin match old_crc, crc with
189 | (None | Some _), None -> ()
190 | None, Some _crc ->
191 (* The [None] behaves like a CRC different from every other. *)
192 raise (DT.Error (Inconsistent_implementation name))
193 | Some old_crc, Some crc ->
194 if old_crc <> crc then begin
195 raise (DT.Error (Inconsistent_implementation name))
196 end
197 end;
198 match unit_state with
199 | Not_initialized ->
200 raise (DT.Error (Linking_error (
201 filename, Uninitialized_global name)))
202 | Check_inited i ->
203 if P.num_globals_inited () < i then begin
204 raise (DT.Error (Linking_error (
205 filename, Uninitialized_global name)))
206 end
207 | Loaded -> ())
208 (UH.implementation_imports ui)
209
210 let check_name filename ui priv ifaces implems =
211 let name = UH.name ui in
212 if String.Map.mem name implems then begin
213 raise (DT.Error (Module_already_loaded name))
214 end;
215 if priv && String.Map.mem name ifaces then begin
216 raise (DT.Error (Private_library_cannot_implement_interface name))
217 end;
218 String.Map.add name (UH.crc ui, filename, DT.Not_initialized) implems
219
220 let check_unsafe_module ui =
221 if (not !unsafe_allowed) && UH.unsafe_module ui then begin
222 raise (DT.Error Unsafe_file)
223 end
224
225 let check filename (units : UH.t list) (state : State.t) ~priv =
226 List.iter (fun ui -> check_unsafe_module ui) units;
227 let new_units =
228 String.Set.of_list (List.map (fun ui -> UH.name ui) units)
229 in
230 let implems =
231 List.fold_left (fun implems ui ->
232 check_name filename ui priv state.ifaces implems)
233 state.implems units
234 in
235 let ifaces =
236 List.fold_left (fun ifaces ui ->
237 check_interface_imports filename ui ifaces)
238 state.ifaces units
239 in
240 let allowed_units = String.Set.union state.allowed_units new_units in
241 let (_ : implem String.Map.t) =
242 List.fold_left
243 (fun acc ui ->
244 check_implementation_imports ~allowed_units filename ui acc;
245 set_loaded_implem filename ui acc)
246 implems units
247 in
248 let defined_symbols =
249 List.fold_left (fun defined_symbols ui ->
250 let descr =
251 lazy (Printf.sprintf "between the executable file (and any \
252 existing dynamically-loaded units) and the unit `%s' being \
253 dynamically loaded from %s"
254 (UH.name ui)
255 filename)
256 in
257 let symbols = String.Set.of_list (UH.defined_symbols ui) in
258 check_symbols_disjoint ~descr symbols defined_symbols;
259 String.Set.union symbols defined_symbols)
260 state.defined_symbols
261 units
262 in
263 if priv then begin
264 state
265 end else begin
266 let public_dynamically_loaded_units =
267 String.Set.union state.public_dynamically_loaded_units new_units
268 in
269 let state =
270 { state with
271 implems;
272 ifaces;
273 defined_symbols;
274 allowed_units;
275 public_dynamically_loaded_units;
276 }
277 in
278 State.invariant state;
279 state
280 end
281
282 let set_allowed_units allowed_units =
283 let allowed_units = String.Set.of_list allowed_units in
284 let state =
285 let state = !global_state in
286 { state with
287 allowed_units;
288 }
289 in
290 global_state := state
291
292 let allow_only units =
293 let allowed_units =
294 String.Set.inter (!global_state).allowed_units
295 (String.Set.of_list units)
296 in
297 let state =
298 let state = !global_state in
299 { state with
300 allowed_units;
301 }
302 in
303 global_state := state
304
305 let prohibit units =
306 let allowed_units =
307 String.Set.diff (!global_state).allowed_units
308 (String.Set.of_list units)
309 in
310 let state =
311 let state = !global_state in
312 { state with
313 allowed_units;
314 }
315 in
316 global_state := state
317
318 let main_program_units () =
319 String.Set.elements (!global_state).main_program_units
320
321 let public_dynamically_loaded_units () =
322 String.Set.elements (!global_state).public_dynamically_loaded_units
323
324 let all_units () =
325 String.Set.elements (String.Set.union
326 (!global_state).main_program_units
327 (!global_state).public_dynamically_loaded_units)
328
329 let dll_filename fname =
330 if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
331 else fname
332
333 let load priv filename =
334 init ();
335 let filename = dll_filename filename in
336 match P.load ~filename ~priv with
337 | exception exn -> raise (DT.Error (Cannot_open_dynamic_library exn))
338 | handle, units ->
339 try
340 global_state := check filename units !global_state ~priv;
341 P.run_shared_startup handle;
342 List.iter
343 (fun unit_header ->
344 P.run handle ~unit_header ~priv;
345 if not priv then begin
346 global_state := set_loaded filename unit_header !global_state
347 end)
348 units;
349 P.finish handle
350 with exn ->
351 P.finish handle;
352 raise exn
353
354 let loadfile filename = load false filename
355 let loadfile_private filename = load true filename
356
357 let unsafe_get_global_value = P.unsafe_get_global_value
358
359 let is_native = P.is_native
360 let adapt_filename = P.adapt_filename
361 end
362