248 lines
7.9 KiB
OCaml
248 lines
7.9 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the GNU Library General Public License, with *)
|
|
(* the special exception on linking described in file ../../LICENSE. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* Dynamic loading of .cmx files *)
|
|
|
|
type handle
|
|
|
|
external ndl_open: string -> bool -> handle * string = "caml_natdynlink_open"
|
|
external ndl_run: handle -> string -> unit = "caml_natdynlink_run"
|
|
external ndl_getmap: unit -> string = "caml_natdynlink_getmap"
|
|
external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
|
|
|
|
type linking_error =
|
|
Undefined_global of string
|
|
| Unavailable_primitive of string
|
|
| Uninitialized_global 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
|
|
| File_not_found of string
|
|
| Cannot_open_dll of string
|
|
| Inconsistent_implementation of string
|
|
|
|
exception Error of error
|
|
|
|
open Cmx_format
|
|
|
|
(* Copied from config.ml to avoid dependencies *)
|
|
let cmxs_magic_number = "Caml2007D001"
|
|
|
|
(* Copied from compilenv.ml to avoid dependencies *)
|
|
let cmx_not_found_crc =
|
|
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
|
|
|
|
let dll_filename fname =
|
|
if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
|
|
else fname
|
|
|
|
let read_file filename priv =
|
|
let dll = dll_filename filename in
|
|
if not (Sys.file_exists dll) then raise (Error (File_not_found dll));
|
|
|
|
let (handle,data) as res = ndl_open dll (not priv) in
|
|
if Obj.tag (Obj.repr res) = Obj.string_tag
|
|
then raise (Error (Cannot_open_dll (Obj.magic res)));
|
|
|
|
let header : dynheader = Marshal.from_string data 0 in
|
|
if header.dynu_magic <> cmxs_magic_number
|
|
then raise(Error(Not_a_bytecode_file dll));
|
|
(dll, handle, header.dynu_units)
|
|
|
|
|
|
|
|
(* Management of interface and implementation CRCs *)
|
|
|
|
module StrMap = Map.Make(String)
|
|
|
|
type implem_state =
|
|
| Loaded
|
|
| Check_inited of int
|
|
|
|
type state = {
|
|
ifaces: (string*string) StrMap.t;
|
|
implems: (string*string*implem_state) StrMap.t;
|
|
}
|
|
|
|
let empty_state = {
|
|
ifaces = StrMap.empty;
|
|
implems = StrMap.empty;
|
|
}
|
|
|
|
let global_state = ref empty_state
|
|
|
|
let allow_extension = ref true
|
|
|
|
let inited = ref false
|
|
|
|
let default_available_units () =
|
|
let map : (string*Digest.t*Digest.t*string list) list =
|
|
Marshal.from_string (ndl_getmap ()) 0 in
|
|
let exe = Sys.executable_name in
|
|
let rank = ref 0 in
|
|
global_state :=
|
|
List.fold_left
|
|
(fun st (name,crc_intf,crc_impl,syms) ->
|
|
rank := !rank + List.length syms;
|
|
{
|
|
ifaces = StrMap.add name (crc_intf,exe) st.ifaces;
|
|
implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems;
|
|
}
|
|
)
|
|
empty_state
|
|
map;
|
|
allow_extension := true;
|
|
inited := true
|
|
|
|
let init () =
|
|
if not !inited then default_available_units ()
|
|
|
|
let add_check_ifaces allow_ext filename ui ifaces =
|
|
List.fold_left
|
|
(fun ifaces (name, crc) ->
|
|
if name = ui.dynu_name
|
|
then StrMap.add name (crc,filename) ifaces
|
|
else
|
|
try
|
|
let (old_crc,old_src) = StrMap.find name ifaces in
|
|
if old_crc <> crc
|
|
then raise(Error(Inconsistent_import(name)))
|
|
else ifaces
|
|
with Not_found ->
|
|
if allow_ext then StrMap.add name (crc,filename) ifaces
|
|
else raise (Error(Unavailable_unit name))
|
|
) ifaces ui.dynu_imports_cmi
|
|
|
|
let check_implems filename ui implems =
|
|
List.iter
|
|
(fun (name, crc) ->
|
|
match name with
|
|
|"Out_of_memory"
|
|
|"Sys_error"
|
|
|"Failure"
|
|
|"Invalid_argument"
|
|
|"End_of_file"
|
|
|"Division_by_zero"
|
|
|"Not_found"
|
|
|"Match_failure"
|
|
|"Stack_overflow"
|
|
|"Sys_blocked_io"
|
|
|"Assert_failure"
|
|
|"Undefined_recursive_module" -> ()
|
|
| _ ->
|
|
try
|
|
let (old_crc,old_src,state) = StrMap.find name implems in
|
|
if crc <> cmx_not_found_crc && old_crc <> crc
|
|
then raise(Error(Inconsistent_implementation(name)))
|
|
else match state with
|
|
| Check_inited i ->
|
|
if ndl_globals_inited() < i
|
|
then raise(Error(Unavailable_unit name))
|
|
| Loaded -> ()
|
|
with Not_found ->
|
|
raise (Error(Unavailable_unit name))
|
|
) ui.dynu_imports_cmx
|
|
|
|
let loadunits filename handle units state =
|
|
let new_ifaces =
|
|
List.fold_left
|
|
(fun accu ui -> add_check_ifaces !allow_extension filename ui accu)
|
|
state.ifaces units in
|
|
let new_implems =
|
|
List.fold_left
|
|
(fun accu ui ->
|
|
check_implems filename ui accu;
|
|
StrMap.add ui.dynu_name (ui.dynu_crc,filename,Loaded) accu)
|
|
state.implems units in
|
|
|
|
let defines = List.flatten (List.map (fun ui -> ui.dynu_defines) units) in
|
|
|
|
ndl_run handle "_shared_startup";
|
|
List.iter (ndl_run handle) defines;
|
|
{ implems = new_implems; ifaces = new_ifaces }
|
|
|
|
let load priv filename =
|
|
init();
|
|
let (filename,handle,units) = read_file filename priv in
|
|
let nstate = loadunits filename handle units !global_state in
|
|
if not priv then global_state := nstate
|
|
|
|
let loadfile filename = load false filename
|
|
let loadfile_private filename = load true filename
|
|
|
|
let allow_only names =
|
|
init();
|
|
let old = !global_state.ifaces in
|
|
let ifaces =
|
|
List.fold_left
|
|
(fun ifaces name ->
|
|
try StrMap.add name (StrMap.find name old) ifaces
|
|
with Not_found -> ifaces)
|
|
StrMap.empty names in
|
|
global_state := { !global_state with ifaces = ifaces };
|
|
allow_extension := false
|
|
|
|
let prohibit names =
|
|
init();
|
|
let ifaces = List.fold_right StrMap.remove names !global_state.ifaces in
|
|
global_state := { !global_state with ifaces = ifaces };
|
|
allow_extension := false
|
|
|
|
let digest_interface _ _ =
|
|
failwith "Dynlink.digest_interface: not implemented in native code"
|
|
let add_interfaces _ _ =
|
|
failwith "Dynlink.add_interfaces: not implemented in native code"
|
|
let add_available_units _ =
|
|
failwith "Dynlink.add_available_units: not implemented in native code"
|
|
let clear_available_units _ =
|
|
failwith "Dynlink.clear_available_units: not implemented in native code"
|
|
let allow_unsafe_modules _ =
|
|
()
|
|
|
|
(* Error report *)
|
|
|
|
let error_message = function
|
|
Not_a_bytecode_file name ->
|
|
name ^ " is not an 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"
|
|
| Linking_error (name, Uninitialized_global s) ->
|
|
"error while linking " ^ name ^ ".\n" ^
|
|
"The module `" ^ s ^ "' is not yet initialized"
|
|
| Corrupted_interface name ->
|
|
"corrupted interface file " ^ name
|
|
| File_not_found name ->
|
|
"cannot find file " ^ name ^ " in search path"
|
|
| Cannot_open_dll reason ->
|
|
"error loading shared library: " ^ reason
|
|
| Inconsistent_implementation name ->
|
|
"implementation mismatch on " ^ name
|
|
|
|
let is_native = true
|
|
let adapt_filename f = Filename.chop_extension f ^ ".cmxs"
|