Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

deduplicate debugger/dynlink.{ml,mli} 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@10413 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Damien Doligez 2010-05-17 15:49:53 +00:00
parent 17a6330d29
commit 1072c2cc6d
8 changed files with 25 additions and 418 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Changes
View File

@ -85,6 +85,7 @@ Ocamlbuild:
- Add support for native dynlink.
Bug Fixes:
- PR#4742: finalisation function raising an exception blocks other finalisations
- PR#4775: compiler crash on crazy types (temporary fix)
- PR#4970: better error message for instance variables
- PR#4988: contravariance lost with ocamlc -i

2
VERSION
View File

@ -1,4 +1,4 @@
3.12.0+dev23 (2010-05-12)
3.12.0+dev24 (2010-05-17)
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli

2
_tags
View File

@ -48,7 +48,7 @@ true: use_stdlib
"tools/addlabels.ml": warn_s
<debugger/main.byte> or <debugger/main.native>: use_unix, use_dynlink, linkall
<debugger/main.byte> or <debugger/main.native>: use_unix, linkall
<debugger/*.ml*>: include_unix
<otherlibs/{,win32}unix/unix.cm{,x}a> or <otherlibs/str/str.cm{,x}a>: ocamlmklib

9
debugger/Makefile.shared
View File

@ -114,4 +114,13 @@ clean::
rm -f parser.ml parser.mli
beforedepend:: parser.ml parser.mli
dynlink.ml: ../otherlibs/dynlink/dynlink.ml
grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \
../otherlibs/dynlink/dynlink.ml >dynlink.ml
dynlink.mli: ../otherlibs/dynlink/dynlink.mli
cp ../otherlibs/dynlink/dynlink.mli .
clean::
rm -f dynlink.ml dynlink.mli
beforedepend:: dynlink.ml dynlink.mli
include .depend

271
debugger/dynlink.ml
View File

@ -1,271 +0,0 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, 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. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Dynamic loading of .cmo files *)
(* This is a copy of ../otherlibs/dynlink/dynlink.ml that does not
use Dynlinkaux (the module that packs some of the compiler modules). *)
open Cmo_format
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
(* Management of interface CRCs *)
let crc_interfaces = ref (Consistbl.create ())
let allow_extension = ref true
(* 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 check_consistency file_name cu =
try
List.iter
(fun (name, crc) ->
if name = cu.cu_name then
Consistbl.set !crc_interfaces name crc file_name
else if !allow_extension then
Consistbl.check !crc_interfaces name crc file_name
else
Consistbl.check_noadd !crc_interfaces name crc file_name)
cu.cu_imports
with Consistbl.Inconsistency(name, user, auth) ->
raise(Error(Inconsistent_import name))
| Consistbl.Not_available(name) ->
raise(Error(Unavailable_unit name))
(* Empty the crc_interfaces table *)
let clear_available_units () =
Consistbl.clear !crc_interfaces;
allow_extension := false
(* Allow only access to the units with the given names *)
let allow_only names =
Consistbl.filter (fun name -> List.mem name names) !crc_interfaces;
allow_extension := false
(* Prohibit access to the units with the given names *)
let prohibit names =
Consistbl.filter (fun name -> not (List.mem name names)) !crc_interfaces;
allow_extension := false
(* Initialize the crc_interfaces table with a list of units with fixed CRCs *)
let add_available_units units =
List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "")
units
(* Default interface CRCs: those found in the current executable *)
let default_crcs = ref []
let default_available_units () =
clear_available_units();
add_available_units !default_crcs;
allow_extension := true
(* Initialize the linker tables and everything *)
let inited = ref false
let init () =
if not !inited then begin
default_crcs := Symtable.init_toplevel();
default_available_units ();
inited := true;
end
let clear_available_units () = init(); clear_available_units ()
let allow_only l = init(); allow_only l
let prohibit l = init(); prohibit l
let add_available_units l = init(); add_available_units l
let default_available_units () = init(); default_available_units ()
(* Read the CRC of an interface from its .cmi file *)
let digest_interface unit loadpath =
let filename =
let shortname = unit ^ ".cmi" in
try
Misc.find_in_path_uncap loadpath shortname
with Not_found ->
raise (Error(File_not_found shortname)) 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;
ignore (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.check_global_initialized 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
| Symtable.Uninitialized_global s -> Uninitialized_global 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 =
init();
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;
let lib = (input_value ic : library) in
begin try
Dll.open_dlls Dll.For_execution
(List.map Dll.extract_dll_name lib.lib_dllibs)
with Failure reason ->
raise(Error(Cannot_open_dll reason))
end;
List.iter (load_compunit ic file_name) lib.lib_units
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 =
init();
let initial_symtable = Symtable.current_state()
and initial_crc = !crc_interfaces in
try
loadfile file_name;
Symtable.hide_additions initial_symtable;
crc_interfaces := initial_crc
with exn ->
Symtable.hide_additions initial_symtable;
crc_interfaces := initial_crc;
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"
| 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 = false
let adapt_filename f = f

143
debugger/dynlink.mli
View File

@ -1,143 +0,0 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, 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. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(** Dynamic loading of object files. *)
val is_native: bool
(** [true] if the program is native,
[false] if the program is bytecode. *)
(** {6 Dynamic loading of compiled files} *)
val loadfile : string -> unit
(** In bytecode: load the given bytecode object file ([.cmo] file) or
bytecode library file ([.cma] file), and link it with the running
program. In native code: load the given OCaml plugin file (usually
[.cmxs]), and link it with the running
program.
All toplevel expressions in the loaded compilation units
are evaluated. No facilities are provided to
access value names defined by the unit. Therefore, the unit
must register itself its entry points with the main program,
e.g. by modifying tables of functions. *)
val loadfile_private : string -> unit
(** Same as [loadfile], except that the compilation units just loaded
are hidden (cannot be referenced) from other modules dynamically
loaded afterwards. *)
val adapt_filename : string -> string
(** In bytecode, the identity function. In native code, replace the last
extension with [.cmxs]. *)
(** {6 Access control} *)
val allow_only: string list -> unit
(** [allow_only units] restricts the compilation units that dynamically-linked
units can reference: it only allows references to the units named in
list [units]. References to any other compilation unit will cause
a [Unavailable_unit] error during [loadfile] or [loadfile_private].
Initially (just after calling [init]), all compilation units composing
the program currently running are available for reference from
dynamically-linked units. [allow_only] can be used to grant access
to some of them only, e.g. to the units that compose the API for
dynamically-linked code, and prevent access to all other units,
e.g. private, internal modules of the running program. *)
val prohibit: string list -> unit
(** [prohibit units] prohibits dynamically-linked units from referencing
the units named in list [units]. This can be used to prevent
access to selected units, e.g. private, internal modules of
the running program. *)
val default_available_units: unit -> unit
(** Reset the set of units that can be referenced from dynamically-linked
code to its default value, that is, all units composing the currently
running program. *)
val allow_unsafe_modules : bool -> unit
(** Govern whether unsafe object files are allowed to be
dynamically linked. A compilation unit is ``unsafe'' if it contains
declarations of external functions, which can break type safety.
By default, dynamic linking of unsafe object files is
not allowed. In native code, this function does nothing; object files
with external functions are always allowed to be dynamically linked. *)
(** {6 Deprecated, low-level API for access control} *)
(** @deprecated The functions [add_interfaces], [add_available_units]
and [clear_available_units] should not be used in new programs,
since the default initialization of allowed units, along with the
[allow_only] and [prohibit] function, provides a better, safer
mechanism to control access to program units. The three functions
below are provided for backward compatibility only and are not
available in native code. *)
val add_interfaces : string list -> string list -> unit
(** [add_interfaces units path] grants dynamically-linked object
files access to the compilation units named in list [units].
The interfaces ([.cmi] files) for these units are searched in
[path] (a list of directory names). *)
val add_available_units : (string * Digest.t) list -> unit
(** Same as {!Dynlink.add_interfaces}, but instead of searching [.cmi] files
to find the unit interfaces, uses the interface digests given
for each unit. This way, the [.cmi] interface files need not be
available at run-time. The digests can be extracted from [.cmi]
files using the [extract_crc] program installed in the
Objective Caml standard library directory. *)
val clear_available_units : unit -> unit
(** Empty the list of compilation units accessible to dynamically-linked
programs. *)
(** {6 Deprecated, initialization} *)
val init : unit -> unit
(** @deprecated Initialize the [Dynlink] library. This function is called
automatically when needed. *)
(** {6 Error reporting} *)
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
(** Errors in dynamic linking are reported by raising the [Error]
exception with a description of the error. *)
val error_message : error -> string
(** Convert an error description to a printable message. *)
(**/**)
(** {6 Internal functions} *)
val digest_interface : string -> string list -> Digest.t

11
myocamlbuild.ml
View File

@ -583,6 +583,17 @@ rule "camlheader"
A"cp"; A"stdlib/camlheader"; A"stdlib/camlheader_ur"])
end;;
(* Private copy of dynlink.{ml,mli} in debugger/ *)
copy_rule "otherlibs/dynlink/dynlink.mli -> debugger/dynlink.mli" "otherlibs/dynlink/dynlink.mli" "debugger/dynlink.mli";;
rule "debugger/dynlink.ml"
~prod: "debugger/dynlink.ml"
~dep: "otherlibs/dynlink/dynlink.ml"
begin fun _ _ ->
Cmd(Sh"grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \
< otherlibs/dynlink/dynlink.ml >debugger/dynlink.ml")
end;;
copy_rule "win32unix use some unix files" "otherlibs/unix/%" "otherlibs/win32unix/%";;
(* Temporary rule *)

4
otherlibs/dynlink/dynlink.ml
View File

@ -15,8 +15,8 @@
(* Dynamic loading of .cmo files *)
open Dynlinkaux
open Dynlinkaux.Cmo_format
open Dynlinkaux (* REMOVE_ME for ../../debugger/dynlink.ml *)
open Cmo_format
type linking_error =
Undefined_global of string