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

Merge pull request #1063 from mshinwell/natdynlink_load_once 

Make (nat)dynlink sound (also fixes MPR#4208, MPR#4229, MPR#4839, MPR#6462, MPR#6957, MPR#6950)
master
Nicolás Ojeda Bär 2018-11-15 13:39:04 +01:00 committed by GitHub
parent 2e5b9d1ef1 d6181f3e25
commit fc238875d2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
101 changed files with 2282 additions and 715 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
.depend
View File

@ -2328,6 +2328,19 @@ asmcomp/debug/reg_with_debug_info.cmx : asmcomp/reg.cmx \
asmcomp/debug/reg_with_debug_info.cmi : asmcomp/reg.cmi \
asmcomp/backend_var.cmi
driver/compdynlink.cmi :
driver/compdynlink_common.cmo : driver/compdynlink_types.cmi \
driver/compdynlink_platform_intf.cmi driver/compdynlink_common.cmi
driver/compdynlink_common.cmx : driver/compdynlink_types.cmx \
driver/compdynlink_platform_intf.cmx driver/compdynlink_common.cmi
driver/compdynlink_common.cmi : driver/compdynlink_platform_intf.cmi
driver/compdynlink_platform_intf.cmo : driver/compdynlink_types.cmi \
driver/compdynlink_platform_intf.cmi
driver/compdynlink_platform_intf.cmx : driver/compdynlink_types.cmx \
driver/compdynlink_platform_intf.cmi
driver/compdynlink_platform_intf.cmi : driver/compdynlink_types.cmi
driver/compdynlink_types.cmo : driver/compdynlink_types.cmi
driver/compdynlink_types.cmx : driver/compdynlink_types.cmi
driver/compdynlink_types.cmi :
driver/compenv.cmo : utils/warnings.cmi utils/profile.cmi utils/misc.cmi \
parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
driver/compenv.cmi
@ -2488,10 +2501,10 @@ toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
parsing/lexer.cmi bytecomp/lambda.cmi typing/includemod.cmi \
asmcomp/import_approx.cmi typing/ident.cmi toplevel/genprintval.cmi \
typing/env.cmi utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \
driver/compenv.cmi driver/compdynlink.cmi utils/clflags.cmi \
typing/btype.cmi middle_end/backend_intf.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
asmcomp/arch.cmo toplevel/opttoploop.cmi
driver/compenv.cmi utils/clflags.cmi typing/btype.cmi \
middle_end/backend_intf.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
asmcomp/asmlink.cmi asmcomp/asmgen.cmi asmcomp/arch.cmo \
toplevel/opttoploop.cmi
toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
bytecomp/translmod.cmx bytecomp/simplif.cmx asmcomp/proc.cmx \
@ -2503,10 +2516,10 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
parsing/lexer.cmx bytecomp/lambda.cmx typing/includemod.cmx \
asmcomp/import_approx.cmx typing/ident.cmx toplevel/genprintval.cmx \
typing/env.cmx utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \
driver/compenv.cmx driver/compdynlink.cmi utils/clflags.cmx \
typing/btype.cmx middle_end/backend_intf.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
asmcomp/arch.cmx toplevel/opttoploop.cmi
driver/compenv.cmx utils/clflags.cmx typing/btype.cmx \
middle_end/backend_intf.cmi parsing/asttypes.cmi parsing/ast_helper.cmx \
asmcomp/asmlink.cmx asmcomp/asmgen.cmx asmcomp/arch.cmx \
toplevel/opttoploop.cmi
toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \
parsing/longident.cmi parsing/location.cmi typing/env.cmi
@ -2592,8 +2605,13 @@ toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \
parsing/asttypes.cmi toplevel/trace.cmi
toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
typing/env.cmi
driver/compdynlink.cmx : asmcomp/cmx_format.cmi driver/compdynlink.cmi
driver/compdynlink.cmo : bytecomp/symtable.cmi bytecomp/opcodes.cmo \
utils/misc.cmi bytecomp/meta.cmi bytecomp/dll.cmi utils/consistbl.cmi \
utils/config.cmi bytecomp/cmo_format.cmi typing/cmi_format.cmi \
driver/compdynlink.cmx : driver/compdynlink_types.cmx \
driver/compdynlink_common.cmx asmcomp/cmx_format.cmi \
driver/compdynlink.cmi
driver/compdynlink.cmo : bytecomp/symtable.cmi bytecomp/opcodes.cmo \
utils/misc.cmi bytecomp/meta.cmi typing/ident.cmi bytecomp/dll.cmi \
utils/config.cmi driver/compdynlink_types.cmi \
driver/compdynlink_common.cmi bytecomp/cmo_format.cmi \
driver/compdynlink.cmi
driver/compdynlink_platform_intf.cmx : driver/compdynlink_types.cmx \
driver/compdynlink_platform_intf.cmi

7
.gitignore vendored
View File

@ -71,6 +71,12 @@ _build
/driver/compdynlink.mlopt
/driver/compdynlink.mlbyte
/driver/compdynlink.mli
/driver/compdynlink_common.ml
/driver/compdynlink_common.mli
/driver/compdynlink_platform_intf.ml
/driver/compdynlink_platform_intf.mli
/driver/compdynlink_types.ml
/driver/compdynlink_types.mli
/emacs/ocamltags
/emacs/*.elc
@ -114,6 +120,7 @@ _build
/ocamltest/tsl_parser.mli
/otherlibs/dynlink/extract_crc
/otherlibs/dynlink/dynlink_platform_intf.mli
/otherlibs/threads/marshal.mli
/otherlibs/threads/stdlib.mli
/otherlibs/threads/unix.mli

4
Changes
View File

@ -176,6 +176,10 @@ Working version
- GPR#2038: Deprecate vm threads
(Jérémie Dimino)
* PR#4208, PR#4229, PR#4839, PR#6462, PR#6957, PR#6950, GPR#1063: Make
(nat)dynlink sound
(Mark Shinwell, Leo White, Nicolás Ojeda Bär, Pierre Chambart)
### Compiler user-interface and warnings:
- GPR#2133: Warn on literal patterns found anywhere in a constructor's

119
Makefile
View File

@ -114,7 +114,9 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
bytecomp/symtable.cmo \
driver/pparse.cmo driver/main_args.cmo \
driver/compenv.cmo driver/compmisc.cmo \
driver/compdynlink.cmo driver/compplugin.cmo driver/makedepend.cmo \
driver/compdynlink_types.cmo driver/compdynlink_platform_intf.cmo \
driver/compdynlink_common.cmo driver/compdynlink.cmo \
driver/compplugin.cmo driver/makedepend.cmo \
driver/compile_common.cmo
@ -1171,31 +1173,116 @@ DYNLINK_DIR=otherlibs/dynlink
driver/compdynlink.mlbyte: $(DYNLINK_DIR)/dynlink.ml driver/compdynlink.mli
grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \
$(DYNLINK_DIR)/dynlink.ml >driver/compdynlink.mlbyte
$(DYNLINK_DIR)/dynlink.ml | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink.mlbyte
driver/compdynlink_common.ml: $(DYNLINK_DIR)/dynlink_common.ml
cat $(DYNLINK_DIR)/dynlink_common.ml | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink_common.ml
driver/compdynlink_common.mli: $(DYNLINK_DIR)/dynlink_common.mli
cat $(DYNLINK_DIR)/dynlink_common.mli | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink_common.mli
driver/compdynlink_types.mli: $(DYNLINK_DIR)/dynlink_types.mli
cp $(DYNLINK_DIR)/dynlink_types.mli driver/compdynlink_types.mli
driver/compdynlink_types.ml: $(DYNLINK_DIR)/dynlink_types.ml
cp $(DYNLINK_DIR)/dynlink_types.ml driver/compdynlink_types.ml
driver/compdynlink_platform_intf.ml: $(DYNLINK_DIR)/dynlink_platform_intf.ml
cat $(DYNLINK_DIR)/dynlink_platform_intf.ml | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink_platform_intf.ml
ifeq ($(NATDYNLINK),true)
driver/compdynlink.mlopt: $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mli
cp $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mlopt
cat $(DYNLINK_DIR)/natdynlink.ml | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink.mlopt
else
driver/compdynlink.mlopt: driver/compdynlink.mlno driver/compdynlink.mli
cp driver/compdynlink.mlno driver/compdynlink.mlopt
driver/compdynlink.mlopt: $(DYNLINK_DIR)/nodynlink.ml driver/compdynlink.mli
cat $(DYNLINK_DIR)/nodynlink.ml | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink.mlopt
endif
driver/compdynlink.mli: $(DYNLINK_DIR)/dynlink.mli
cp $(DYNLINK_DIR)/dynlink.mli driver/compdynlink.mli
cat $(DYNLINK_DIR)/dynlink.mli | \
sed 's/Dynlink_/Compdynlink_/g' \
> driver/compdynlink.mli
driver/compdynlink.cmo: driver/compdynlink.mlbyte driver/compdynlink.cmi
driver/compdynlink_types.cmi: driver/compdynlink_types.mli
$(CAMLC) $(COMPFLAGS) -c $<
driver/compdynlink_types.cmo: driver/compdynlink_types.ml \
driver/compdynlink_types.cmi
$(CAMLC) $(COMPFLAGS) -c $<
driver/compdynlink_types.cmx: driver/compdynlink_types.ml \
driver/compdynlink_types.cmi
$(CAMLOPT) $(COMPFLAGS) -c $<
# See comment in otherlibs/dynlink/Makefile about these two rules.
driver/compdynlink_platform_intf.mli: driver/compdynlink_platform_intf.ml
cp $< $@
driver/compdynlink_platform_intf.cmi: driver/compdynlink_platform_intf.mli \
driver/compdynlink_types.cmi
$(CAMLC) $(COMPFLAGS) -c $<
driver/compdynlink_platform_intf.cmo: driver/compdynlink_platform_intf.ml \
driver/compdynlink_platform_intf.cmi \
driver/compdynlink_types.cmo
$(CAMLC) $(COMPFLAGS) -c $<
driver/compdynlink_platform_intf.cmx: driver/compdynlink_platform_intf.ml \
driver/compdynlink_platform_intf.cmi \
driver/compdynlink_types.cmx
$(CAMLOPT) $(COMPFLAGS) -c $<
driver/compdynlink_common.cmi: driver/compdynlink_common.mli \
driver/compdynlink_platform_intf.cmi
$(CAMLC) $(COMPFLAGS) -c $<
driver/compdynlink_common.cmo: driver/compdynlink_common.ml \
driver/compdynlink_common.cmi \
driver/compdynlink_platform_intf.cmo
$(CAMLC) $(COMPFLAGS) -c $<
driver/compdynlink_common.cmx: driver/compdynlink_common.ml \
driver/compdynlink_common.cmi \
driver/compdynlink_platform_intf.cmx
$(CAMLOPT) $(COMPFLAGS) -c $<
driver/compdynlink.cmo: driver/compdynlink.mlbyte driver/compdynlink.cmi \
driver/compdynlink_common.cmi driver/compdynlink_common.cmo
$(CAMLC) $(COMPFLAGS) -c -impl $<
driver/compdynlink.cmx: driver/compdynlink.mlopt driver/compdynlink.cmi
driver/compdynlink.cmx: driver/compdynlink.mlopt driver/compdynlink.cmi \
driver/compdynlink_common.cmi driver/compdynlink_common.cmx
$(CAMLOPT) $(COMPFLAGS) -c -impl $<
beforedepend:: driver/compdynlink.mlbyte driver/compdynlink.mlopt \
driver/compdynlink.mli
beforedepend:: driver/compdynlink.mlbyte \
driver/compdynlink.mlopt \
driver/compdynlink_platform_intf.ml \
driver/compdynlink_types.ml \
driver/compdynlink_types.mli \
driver/compdynlink.mli \
driver/compdynlink_common.ml \
driver/compdynlink_common.mli
partialclean::
rm -f driver/compdynlink.mlbyte
rm -f driver/compdynlink.mli
rm -f driver/compdynlink.mlopt
rm -f driver/compdynlink.mli
rm -f driver/compdynlink_platform_intf.ml
rm -f driver/compdynlink_common.mlbyte
rm -f driver/compdynlink_common.mlopt
rm -f driver/compdynlink_common.mli
rm -f driver/compdynlink_types.mli
rm -f driver/compdynlink_types.ml
# The native toplevel
@ -1296,6 +1383,16 @@ depend: beforedepend
-impl driver/compdynlink.mlopt >> .depend
$(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
-impl driver/compdynlink.mlbyte >> .depend
$(CAMLDEP) -slash $(DEPFLAGS) -native \
-impl driver/compdynlink_common.mlopt >> .depend
$(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
-impl driver/compdynlink_common.mlbyte >> .depend
$(CAMLDEP) -slash $(DEPFLAGS) -native \
-impl driver/compdynlink_platform_intf.ml >> .depend
$(CAMLDEP) -slash $(DEPFLAGS) -native \
-impl driver/compdynlink_types.mlopt >> .depend
$(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
-impl driver/compdynlink_types.mlbyte >> .depend
.PHONY: distclean
distclean: clean

35
asmcomp/asmlink.ml
View File

@ -20,6 +20,8 @@ open Config
open Cmx_format
open Compilenv
module String = Misc.Stdlib.String
type error =
File_not_found of string
| Not_an_object_file of string
@ -207,7 +209,20 @@ let force_linking_of_startup ~ppf_dump =
Asmgen.compile_phrase ~ppf_dump
(Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"]))
let make_startup_file ~ppf_dump units_list =
let make_globals_map units_list ~crc_interfaces =
let crc_interfaces = String.Tbl.of_seq (List.to_seq crc_interfaces) in
let defined =
List.map (fun (unit, _, impl_crc) ->
let intf_crc = String.Tbl.find crc_interfaces unit.ui_name in
String.Tbl.remove crc_interfaces unit.ui_name;
(unit.ui_name, intf_crc, Some impl_crc, unit.ui_defines))
units_list
in
String.Tbl.fold (fun name intf acc ->
(name, intf, None, []) :: acc)
crc_interfaces defined
let make_startup_file ~ppf_dump units_list ~crc_interfaces =
let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in
Location.input_name := "caml_startup"; (* set name of "current" input *)
Compilenv.reset "_startup";
@ -222,19 +237,8 @@ let make_startup_file ~ppf_dump units_list =
(fun i name -> compile_phrase (Cmmgen.predef_exception i name))
Runtimedef.builtin_exceptions;
compile_phrase (Cmmgen.global_table name_list);
compile_phrase
(Cmmgen.globals_map
(List.map
(fun (unit,_,crc) ->
let intf_crc =
try
match List.assoc unit.ui_name unit.ui_imports_cmi with
None -> assert false
| Some crc -> crc
with Not_found -> assert false
in
(unit.ui_name, intf_crc, crc, unit.ui_defines))
units_list));
let globals_map = make_globals_map units_list ~crc_interfaces in
compile_phrase (Cmmgen.globals_map globals_map);
compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list));
compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list));
let all_names = "_startup" :: "_system" :: name_list in
@ -341,6 +345,7 @@ let link ~ppf_dump objfiles output_name =
List.iter
(fun (info, file_name, crc) -> check_consistency file_name info crc)
units_tolink;
let crc_interfaces = extract_crc_interfaces () in
Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
(* put user's opts first *)
@ -351,7 +356,7 @@ let link ~ppf_dump objfiles output_name =
let startup_obj = Filename.temp_file "camlstartup" ext_obj in
Asmgen.compile_unit output_name
startup !Clflags.keep_startup_file startup_obj
(fun () -> make_startup_file ~ppf_dump units_tolink);
(fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces);
Misc.try_finally
(fun () ->
call_linker (List.map object_file_name objfiles)

4
asmcomp/cmmgen.mli
View File

@ -29,8 +29,8 @@ val generic_functions: bool -> Cmx_format.unit_infos list -> Cmm.phrase list
val entry_point: string list -> Cmm.phrase
val global_table: string list -> Cmm.phrase
val reference_symbols: string list -> Cmm.phrase
val globals_map: (string * Digest.t * Digest.t * string list) list ->
Cmm.phrase
val globals_map:
(string * Digest.t option * Digest.t option * string list) list -> Cmm.phrase
val frame_table: string list -> Cmm.phrase
val spacetime_shapes: string list -> Cmm.phrase
val data_segment_table: string list -> Cmm.phrase

21
bytecomp/symtable.ml
View File

@ -334,15 +334,17 @@ let assign_global_value id v =
(* Check that all globals referenced in the given patch list
have been initialized already *)
let defined_globals patchlist =
List.fold_left (fun accu rel ->
match rel with
| (Reloc_setglobal id, _pos) -> id :: accu
| _ -> accu)
[]
patchlist
let check_global_initialized patchlist =
(* First determine the globals we will define *)
let defined_globals =
List.fold_left
(fun accu rel ->
match rel with
(Reloc_setglobal id, _pos) -> id :: accu
| _ -> accu)
[] patchlist in
let defined_globals = defined_globals patchlist in
(* Then check that all referenced, not defined globals have a value *)
let check_reference = function
(Reloc_getglobal id, _pos) ->
@ -381,6 +383,11 @@ let filter_global_map p (gmap : global_map) =
let iter_global_map f (gmap : global_map) =
Ident.Map.iter f gmap.tbl
let is_defined_in_global_map (gmap : global_map) id =
Ident.Map.mem id gmap.tbl
let empty_global_map = GlobalMap.empty
(* Error report *)
open Format

3
bytecomp/symtable.mli
View File

@ -39,14 +39,17 @@ val is_global_defined: Ident.t -> bool
val assign_global_value: Ident.t -> Obj.t -> unit
val get_global_position: Ident.t -> int
val check_global_initialized: (reloc_info * int) list -> unit
val defined_globals: (reloc_info * int) list -> Ident.t list
type global_map
val empty_global_map: global_map
val current_state: unit -> global_map
val restore_state: global_map -> unit
val hide_additions: global_map -> unit
val filter_global_map: (Ident.t -> bool) -> global_map -> global_map
val iter_global_map : (Ident.t -> int -> unit) -> global_map -> unit
val is_defined_in_global_map: global_map -> Ident.t -> bool
(* Error report *)

5
debugger/Makefile
View File

@ -51,8 +51,9 @@ typing_modules := $(addprefix typing/,\
bytecomp_modules := $(addprefix bytecomp/,\
runtimedef bytesections dll meta symtable opcodes)
other_compiler_modules := \
driver/compdynlink toplevel/genprintval
other_compiler_modules := driver/compdynlink_types \
driver/compdynlink_platform_intf \
driver/compdynlink_common driver/compdynlink toplevel/genprintval
compiler_modules := $(addprefix $(ROOTDIR)/,\
$(utils_modules) $(parsing_modules) $(typing_modules) \

1
debugger/loadprinter.ml
View File

@ -41,7 +41,6 @@ let use_debugger_symtable fn arg =
let old_symtable = Symtable.current_state() in
begin match !debugger_symtable with
| None ->
Compdynlink.init();
Compdynlink.allow_unsafe_modules true;
debugger_symtable := Some(Symtable.current_state())
| Some st ->

3
driver/compplugin.ml
View File

@ -30,7 +30,8 @@ let load plugin_name =
Compmisc.init_path !Clflags.native_code;
Misc.find_in_path !Config.load_path plugin_name
with Not_found ->
raise (Compdynlink.Error (Compdynlink.File_not_found plugin_name))
failwith (Printf.sprintf "Cannot find plugin %s in load path"
plugin_name)
else plugin_name
in

95
otherlibs/dynlink/Makefile
View File

@ -37,26 +37,27 @@ else
OPTCOMPFLAGS=
endif
OBJS=dynlinkaux.cmo dynlink.cmo
OBJS=dynlink_compilerlibs.cmo dynlink_types.cmo \
dynlink_platform_intf.cmo dynlink_common.cmo dynlink.cmo
NATOBJS=dynlink_types.cmx dynlink_platform_intf.cmx \
dynlink_common.cmx dynlink.cmx
COMPILEROBJS = $(addprefix $(ROOTDIR)/,\
utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \
utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
utils/clflags.cmo utils/consistbl.cmo \
utils/terminfo.cmo utils/warnings.cmo \
parsing/asttypes.cmi parsing/location.cmo parsing/longident.cmo \
parsing/location.cmo parsing/longident.cmo \
parsing/docstrings.cmo parsing/syntaxerr.cmo \
parsing/ast_helper.cmo parsing/ast_mapper.cmo parsing/ast_iterator.cmo \
parsing/attr_helper.cmo parsing/builtin_attributes.cmo \
typing/ident.cmo typing/path.cmo typing/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/subst.cmo typing/predef.cmo \
typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \
bytecomp/lambda.cmo bytecomp/instruct.cmo bytecomp/cmo_format.cmi \
bytecomp/lambda.cmo bytecomp/instruct.cmo \
bytecomp/opcodes.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \
bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo)
NATOBJS=dynlink.cmx
all: dynlink.cma extract_crc
allopt: dynlink.cmxa
@ -67,17 +68,76 @@ dynlink.cma: $(OBJS)
dynlink.cmxa: $(NATOBJS)
$(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o $@ $^
dynlinkaux.cmo: $(COMPILEROBJS)
dynlink_compilerlibs.cmo: $(COMPILEROBJS)
$(OCAMLC) $(COMPFLAGS) -pack -o $@ $^
dynlinkaux.cmi: dynlinkaux.cmo
# This rule is ok since there is no corresponding rule for native code
# compilation (otherwise we would fall foul of the problem in the next
# comment).
dynlink_compilerlibs.cmi: dynlink_compilerlibs.cmo
dynlink.cmx: dynlink.cmi natdynlink.ml
cp natdynlink.ml dynlink.mlopt
# Since there is no .mli for [Dynlink_platform_intf], we need to be
# careful that compilation of the .cmx file does not write the .cmi file again,
# which would cause rebuilding of ocamlopt. The easiest way to do this seems
# to be to copy the .ml file, which is a valid .mli, to the .mli.
dynlink_platform_intf.mli: dynlink_platform_intf.ml
cp $< $@
dynlink_platform_intf.cmi: dynlink_platform_intf.mli \
dynlink_types.cmi
$(OCAMLC) $(COMPFLAGS) -c $<
dynlink_platform_intf.cmo: dynlink_platform_intf.ml \
dynlink_platform_intf.cmi \
dynlink_types.cmo
$(OCAMLC) $(COMPFLAGS) -c dynlink_platform_intf.ml
dynlink_platform_intf.cmx: dynlink_platform_intf.ml \
dynlink_platform_intf.cmi \
dynlink_types.cmx
$(OCAMLOPT) $(COMPFLAGS) -c dynlink_platform_intf.ml
dynlink_types.cmi: dynlink_types.mli
$(OCAMLC) $(COMPFLAGS) -c dynlink_types.mli
dynlink_types.cmo: dynlink_types.ml dynlink_types.cmi
$(OCAMLC) $(COMPFLAGS) -c dynlink_types.ml
dynlink_types.cmx: dynlink_types.ml dynlink_types.cmi
$(OCAMLOPT) $(COMPFLAGS) -c dynlink_types.ml
dynlink_common.cmi: dynlink_common.mli \
dynlink_platform_intf.cmi \
dynlink_types.cmi
$(OCAMLC) $(COMPFLAGS) -c dynlink_common.mli
dynlink_common.cmo: dynlink_common.ml \
dynlink_common.cmi \
dynlink_platform_intf.cmo
$(OCAMLC) $(COMPFLAGS) -c dynlink_common.ml
dynlink_common.cmx: dynlink_common.ml \
dynlink_common.cmi \
dynlink_platform_intf.cmx
$(OCAMLOPT) $(COMPFLAGS) -c dynlink_common.ml
dynlink.cmi: dynlink.mli dynlink_compilerlibs.cmi
$(OCAMLC) -c $(COMPFLAGS) dynlink.mli
dynlink.cmo: dynlink.cmi dynlink_common.cmi \
dynlink_types.cmo dynlink_common.cmo dynlink.ml \
dynlink_compilerlibs.cmo
$(OCAMLC) -c $(COMPFLAGS) -impl dynlink.ml
dynlink.cmx: dynlink.cmi dynlink_common.cmi \
dynlink_types.cmx dynlink_common.cmx natdynlink.ml
cp natdynlink.ml dynlink.mlopt
$(OCAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt
rm -f dynlink.mlopt
extract_crc: dynlink.cma extract_crc.cmo
extract_crc.cmo: extract_crc.ml dynlink.cmi
$(OCAMLC) -c $(COMPFLAGS) extract_crc.ml
extract_crc: $(COMPILEROBJS) dynlink.cma extract_crc.cmo
$(OCAMLC) -o $@ $^
install:
@ -106,19 +166,4 @@ partialclean:
clean: partialclean
rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.mli.cmi:
$(OCAMLC) -c $(COMPFLAGS) $<
.ml.cmo:
$(OCAMLC) -c $(COMPFLAGS) $<
.ml.cmx:
$(OCAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
depend:
dynlink.cmi: dynlinkaux.cmi
dynlink.cmo: dynlink.cmi dynlinkaux.cmo
extract_crc.cmo: dynlink.cmi

2
otherlibs/dynlink/dune
View File

@ -15,7 +15,7 @@
(library
(name dynlink)
(wrapped false)
(modules dynlink dynlinkaux)
(modules dynlink dynlinkaux dynlink_common dynlink_types)
; the -33 is specific to the hackery done with dune.
(flags (:standard -nostdlib -w -33))
(libraries ocamlcommon stdlib))

458
otherlibs/dynlink/dynlink.ml
View File

@ -1,12 +1,14 @@
#2 "otherlibs/dynlink/dynlink.ml"
#3 "otherlibs/dynlink/dynlink.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
@ -14,317 +16,167 @@
(* *)
(**************************************************************************)
(* Dynamic loading of .cmo files *)
[@@@ocaml.warning "+a-4-30-40-41-42"]
open Dynlinkaux (* REMOVE_ME for ../../debugger/dynlink.ml *)
open Cmo_format
open! Dynlink_compilerlibs (* REMOVE_ME for ../../debugger/dynlink.ml *)
type linking_error =
Undefined_global of string
module DC = Dynlink_common
module DT = Dynlink_types
module Bytecode = struct
type filename = string
module Unit_header = struct
type t = Cmo_format.compilation_unit
let name (t : t) = t.cu_name
let crc _t = None
let interface_imports (t : t) = t.cu_imports
let implementation_imports _t = []
let defined_symbols (t : t) =
List.map (fun ident -> Ident.name ident)
(Symtable.defined_globals t.cu_reloc)
let unsafe_module (t : t) = t.cu_primitives <> []
end
type handle = Stdlib.in_channel * filename * Digest.t
let default_crcs = ref []
let default_global_map = ref Symtable.empty_global_map
let init () =
if !Sys.interactive then begin (* PR#6802 *)
invalid_arg "The dynlink.cma library cannot be used \
inside the OCaml toplevel"
end;
default_crcs := Symtable.init_toplevel ();
default_global_map := Symtable.current_state ()
let is_native = false
let adapt_filename f = f
let num_globals_inited () =
Misc.fatal_error "Should never be called for bytecode dynlink"
let fold_initial_units ~init ~f =
List.fold_left (fun acc (comp_unit, interface) ->
let id = Ident.create_persistent comp_unit in
let defined =
Symtable.is_defined_in_global_map !default_global_map id
in
let implementation =
if defined then Some (None, DT.Loaded)
else None
in
let defined_symbols =
if defined then [comp_unit]
else []
in
f acc ~comp_unit ~interface ~implementation ~defined_symbols)
init
!default_crcs
let run (ic, file_name, file_digest) ~unit_header ~priv =
let open Misc in
let old_state = Symtable.current_state () in
let compunit : Cmo_format.compilation_unit = unit_header in
seek_in ic compunit.cu_pos;
let code_size = compunit.cu_codesize + 8 in
let code = LongString.create code_size in
LongString.input_bytes_into code ic compunit.cu_codesize;
LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
LongString.blit_string "\000\000\000\001\000\000\000" 0
code (compunit.cu_codesize + 1) 7;
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 : DT.linking_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
| Symtable.Wrong_vm _ -> assert false
in
raise (DT.Error (Linking_error (file_name, new_error)))
end;
(* PR#5215: identify this code fragment by
digest of file contents + unit name.
Unit name is needed for .cma files, which produce several code
fragments. *)
let digest = Digest.string (file_digest ^ compunit.cu_name) in
let events =
if compunit.cu_debug = 0 then [| |]
else begin
seek_in ic compunit.cu_debug;
[| input_value ic |]
end in
if priv then Symtable.hide_additions old_state;
let _, clos = Meta.reify_bytecode code events (Some digest) in
try ignore ((clos ()) : Obj.t)
with exn -> raise (DT.Error (Library's_module_initializers_failed exn))
let load ~filename:file_name ~priv:_ =
let ic = open_in_bin file_name in
let file_digest = Digest.channel ic (-1) in
seek_in ic 0;
try
let buffer =
try really_input_string ic (String.length Config.cmo_magic_number)
with End_of_file -> raise (DT.Error (Not_a_bytecode_file file_name))
in
let handle = ic, file_name, file_digest in
if buffer = Config.cmo_magic_number then begin
let compunit_pos = input_binary_int ic in (* Go to descriptor *)
seek_in ic compunit_pos;
let cu = (input_value ic : Cmo_format.compilation_unit) in
handle, [cu]
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 : Cmo_format.library) in
begin try
Dll.open_dlls Dll.For_execution
(List.map Dll.extract_dll_name lib.lib_dllibs)
with exn ->
raise (DT.Error (Cannot_open_dynamic_library exn))
end;
handle, lib.lib_units
end else begin
raise (DT.Error (Not_a_bytecode_file file_name))
end
with exc ->
close_in ic;
raise exc
let finish (ic, _filename, _digest) =
close_in ic
end
include DC.Make (Bytecode)
type linking_error = DT.linking_error =
| Undefined_global of string
| Unavailable_primitive of string
| Uninitialized_global of string
type error =
Not_a_bytecode_file of string
type error = DT.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
| Cannot_open_dynamic_library of exn
| Library's_module_initializers_failed of exn
| Inconsistent_implementation of string
| Module_already_loaded of string
| Private_library_cannot_implement_interface of string
exception Error of error
let () =
Printexc.register_printer
(function
| Error err ->
let msg = match err with
| Not_a_bytecode_file s ->
Printf.sprintf "Not_a_bytecode_file %S" s
| Inconsistent_import s ->
Printf.sprintf "Inconsistent_import %S" s
| Unavailable_unit s ->
Printf.sprintf "Unavailable_unit %S" s
| Unsafe_file ->
"Unsafe_file"
| Linking_error (s, Undefined_global s') ->
Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)"
s s'
| Linking_error (s, Unavailable_primitive s') ->
Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive \
%S)" s s'
| Linking_error (s, Uninitialized_global s') ->
Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global \
%S)" s s'
| Corrupted_interface s ->
Printf.sprintf "Corrupted_interface %S" s
| File_not_found s ->
Printf.sprintf "File_not_found %S" s
| Cannot_open_dll s ->
Printf.sprintf "Cannot_open_dll %S" s
| Inconsistent_implementation s ->
Printf.sprintf "Inconsistent_implementation %S" s in
Some (Printf.sprintf "Dynlink.Error(Dynlink.%s)" msg)
| _ -> None)
(* 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, crco) ->
match crco with
None -> ()
| Some 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();
List.iter
(fun (unit, crco) ->
match crco with
None -> ()
| Some crc -> Consistbl.set !crc_interfaces unit crc "")
!default_crcs;
allow_extension := true
(* Initialize the linker tables and everything *)
let inited = ref false
let init () =
if not !inited then begin
if !Sys.interactive then (* PR#6802 *)
invalid_arg "The dynlink.cma library cannot be used \
inside the OCaml toplevel";
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 =
really_input_string ic (String.length Config.cmi_magic_number)
in
if buffer <> Config.cmi_magic_number then begin
close_in ic;
raise(Error(Corrupted_interface filename))
end;
let cmi = Cmi_format.input_cmi ic in
close_in ic;
let crc =
match cmi.Cmi_format.cmi_crcs with
(_, Some crc) :: _ -> crc
| _ -> raise(Error(Corrupted_interface filename))
in
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 file_digest compunit =
let open Misc in
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 = LongString.create code_size in
LongString.input_bytes_into code ic compunit.cu_codesize;
LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
LongString.blit_string "\000\000\000\001\000\000\000" 0
code (compunit.cu_codesize + 1) 7;
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;
(* PR#5215: identify this code fragment by
digest of file contents + unit name.
Unit name is needed for .cma files, which produce several code fragments.*)
let digest = Digest.string (file_digest ^ compunit.cu_name) in
let events =
if compunit.cu_debug = 0 then [| |]
else begin
seek_in ic compunit.cu_debug;
[| input_value ic |]
end in
begin try
let _, clos = Meta.reify_bytecode code events (Some digest) in
ignore (clos ())
with exn ->
Symtable.restore_state initial_symtable;
raise exn
end
let loadfile file_name =
init();
if not (Sys.file_exists file_name)
then raise (Error (File_not_found file_name));
let ic = open_in_bin file_name in
let file_digest = Digest.channel ic (-1) in
seek_in ic 0;
try
let buffer =
try really_input_string ic (String.length Config.cmo_magic_number)
with End_of_file -> raise (Error (Not_a_bytecode_file file_name))
in
if buffer = Config.cmo_magic_number then begin
let compunit_pos = input_binary_int ic in (* Go to descriptor *)
seek_in ic compunit_pos;
let cu = (input_value ic : compilation_unit) in
load_compunit ic file_name file_digest cu
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 file_digest) 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
exception Error = DT.Error
let error_message = DT.error_message

157
otherlibs/dynlink/dynlink.mli
View File

@ -3,9 +3,11 @@
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
@ -13,9 +15,11 @@
(* *)
(**************************************************************************)
(** Dynamic loading of object files. *)
(** Dynamic loading of .cmo, .cma and .cmxs files. *)
val is_native: bool
[@@@ocaml.warning "+a-4-30-40-41-42"]
val is_native : bool
(** [true] if the program is native,
[false] if the program is bytecode. *)
@ -25,18 +29,44 @@ 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.
[.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. *)
must itself register its entry points with the main program (or a
previously-loaded library) e.g. by modifying tables of functions.
An exception will be raised if the given library defines toplevel
modules whose names clash with modules existing either in the main
program or a shared library previously loaded with [loadfile].
Modules from shared libraries previously loaded with
[loadfile_private] are not included in this restriction.
The compilation units loaded by this function are added to the
"allowed units" list (see {!set_allowed_units}). *)
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. *)
loaded afterwards.
An exception will be raised if the given library defines toplevel
modules whose names clash with modules existing in either the main
program or a shared library previously loaded with [loadfile].
Modules from shared libraries previously loaded with
[loadfile_private] are not included in this restriction.
An exception will also be raised if the given library defines
toplevel modules whose name matches that of an interface depended
on by a module existing in either the main program or a shared
library previously loaded with [loadfile]. This applies even if
such dependency is only a "module alias" dependency (i.e. just on
the name rather than the contents of the interface).
The compilation units loaded by this function are not added to the
"allowed units" list (see {!set_allowed_units}) since they cannot
be referenced from other compilation units. *)
val adapt_filename : string -> string
(** In bytecode, the identity function. In native code, replace the last
@ -44,34 +74,43 @@ val adapt_filename : string -> string
(** {1 Access control} *)
val allow_only: string list -> unit
(** [allow_only units] restricts the compilation units that
dynamically-linked units can reference: it forbids all references
to units other than those named in the list [units]. References
to any other compilation unit will cause a [Unavailable_unit]
error during [loadfile] or [loadfile_private].
val set_allowed_units : string list -> unit
(** Set the list of compilation units that may be referenced from units that
are dynamically loaded in the future to be exactly the given value.
Initially (or after calling [default_available_units]) all
compilation units composing the program currently running are
available for reference from dynamically-linked units.
[allow_only] can be used to restrict access to a subset of these
Initially all compilation units composing the program currently running
are available for reference from dynamically-linked units.
[set_allowed_units] can be used to restrict access to a subset of these
units, 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. If
[allow_only] is called several times, access will be restricted to
the intersection of the given lists (i.e. a call to [allow_only]
can never increase the set of available units). *)
e.g. private, internal modules of the running program.
val prohibit: string list -> unit
Note that {!loadfile} changes the allowed-units list. *)
val allow_only: string list -> unit
(** [allow_only units] sets the list of allowed units to be the intersection
of the existing allowed units and the given list of units. As such it
can never increase the set of allowed units. *)
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. *)
the units named in list [units] by removing such units from the allowed
units list. 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 main_program_units : unit -> string list
(** Return the list of compilation units that form the main program (i.e.
are not dynamically linked). *)
val public_dynamically_loaded_units : unit -> string list
(** Return the list of compilation units that have been dynamically loaded via
[loadfile] (and not via [loadfile_private]). Note that compilation units
loaded dynamically cannot be unloaded. *)
val all_units : unit -> string list
(** Return the list of compilation units that form the main program together
with those that have been dynamically loaded via [loadfile] (and not via
[loadfile_private]). *)
val allow_unsafe_modules : bool -> unit
(** Govern whether unsafe object files are allowed to be
@ -81,68 +120,32 @@ val allow_unsafe_modules : bool -> unit
not allowed. In native code, this function does nothing; object files
with external functions are always allowed to be dynamically linked. *)
(** {1 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
OCaml standard library directory. *)
val clear_available_units : unit -> unit
(** Empty the list of compilation units accessible to dynamically-linked
programs. *)
(** {1 Deprecated, initialization} *)
val init : unit -> unit
(** @deprecated Initialize the [Dynlink] library. This function is called
automatically when needed. *)
(** {1 Error reporting} *)
type linking_error =
Undefined_global of string
type linking_error = private
| Undefined_global of string
| Unavailable_primitive of string
| Uninitialized_global of string
type error =
Not_a_bytecode_file of string
type error = private
| 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
| Cannot_open_dynamic_library of exn
| Library's_module_initializers_failed of exn
| Inconsistent_implementation of string
| Module_already_loaded of string
| Private_library_cannot_implement_interface of string
exception Error of error
(** Errors in dynamic linking are reported by raising the [Error]
exception with a description of the error. *)
exception with a description of the error.
A common case is the dynamic library not being found on the system: this
is reported via [Cannot_open_dynamic_library] (the enclosed exception may
be platform-specific). *)
val error_message : error -> string
(** Convert an error description to a printable message. *)
(**/**)
(** {1 Internal functions} *)
val digest_interface : string -> string list -> Digest.t

358
otherlibs/dynlink/dynlink_common.ml Normal file
View File

@ -0,0 +1,358 @@
#2 "otherlibs/dynlink/dynlink_common.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-30-40-41-42"]
(* This compilation unit cannot depend on compilerlibs. *)
module String = struct
include String
module Set = Set.Make (String)
module Map = struct
include Map.Make (String)
let keys t =
fold (fun key _data keys -> Set.add key keys) t Set.empty
end
end
module Make (P : Dynlink_platform_intf.S) = struct
module DT = Dynlink_types
module UH = P.Unit_header
type interface_dep =
| Name (* the only use of the interface can be via a module alias *)
| Contents of Digest.t
type implem = Digest.t option * DT.filename * DT.implem_state
module State = struct
type t = {
ifaces : (interface_dep * DT.filename) String.Map.t;
(* Interfaces that have been depended upon. *)
implems : implem String.Map.t;
(* Implementations that exist in the main program or have been
dynamically loaded. *)
defined_symbols : String.Set.t;
(* Symbols corresponding to compilation units or packed modules (cf.
[Asmpackager.build_package_cmx]). Used as a sanity check. *)
allowed_units : String.Set.t;
(* Units that are allowed to be referenced by a subsequently-loaded
dynamic library. *)
main_program_units : String.Set.t;
(* Units forming part of the main program (i.e. not dynamically
linked). *)
public_dynamically_loaded_units : String.Set.t;
(* All units that have been dynamically linked, not including those that
were privately loaded. *)
}
let invariant t =
let ifaces = String.Map.keys t.ifaces in
let implems = String.Map.keys t.implems in
assert (String.Set.subset implems ifaces);
assert (String.Set.subset t.main_program_units ifaces);
assert (String.Set.subset t.main_program_units implems);
assert (String.Set.subset t.public_dynamically_loaded_units ifaces);
assert (String.Set.subset t.public_dynamically_loaded_units implems)
let empty = {
ifaces = String.Map.empty;
implems = String.Map.empty;
defined_symbols = String.Set.empty;
allowed_units = String.Set.empty;
main_program_units = String.Set.empty;
public_dynamically_loaded_units = String.Set.empty;
}
end
let global_state = ref State.empty
let inited = ref false
let unsafe_allowed = ref false
let allow_unsafe_modules b =
unsafe_allowed := b
let check_symbols_disjoint ~descr syms1 syms2 =
let exe = Sys.executable_name in
let overlap = String.Set.inter syms1 syms2 in
if not (String.Set.is_empty overlap) then begin
let msg =
Format.asprintf "%s: symbols multiply-defined %s: %a"
exe (Lazy.force descr)
(Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
Format.pp_print_string)
(String.Set.elements overlap)
in
failwith msg
end
let default_available_units () =
let exe = Sys.executable_name in
let ifaces, implems, defined_symbols =
P.fold_initial_units
~init:(String.Map.empty, String.Map.empty, String.Set.empty)
~f:(fun (ifaces, implems, defined_symbols)
~comp_unit ~interface ~implementation
~defined_symbols:defined_symbols_this_unit ->
let ifaces =
match interface with
| None -> String.Map.add comp_unit (Name, exe) ifaces
| Some crc -> String.Map.add comp_unit (Contents crc, exe) ifaces
in
let implems =
match implementation with
| None -> implems
| Some (crc, state) ->
String.Map.add comp_unit (crc, exe, state) implems
in
let defined_symbols_this_unit =
String.Set.of_list defined_symbols_this_unit
in
check_symbols_disjoint ~descr:(lazy "in the executable file")
defined_symbols_this_unit defined_symbols;
let defined_symbols =
String.Set.union defined_symbols_this_unit defined_symbols
in
ifaces, implems, defined_symbols)
in
let main_program_units = String.Map.keys implems in
let state : State.t =
{ ifaces;
implems;
defined_symbols;
allowed_units = main_program_units;
main_program_units;
public_dynamically_loaded_units = String.Set.empty;
}
in
global_state := state
let init () =
if not !inited then begin
P.init ();
default_available_units ();
inited := true
end
let check_interface_imports filename ui ifaces ~allowed_units =
List.fold_left (fun ifaces (name, crc) ->
let add_interface crc =
if String.Set.mem name allowed_units then
String.Map.add name (crc, filename) ifaces
else
raise (DT.Error (Unavailable_unit name))
in
match String.Map.find name ifaces with
| exception Not_found ->
begin match crc with
| None -> add_interface Name
| Some crc -> add_interface (Contents crc)
end
| old_crc, _old_src ->
match old_crc, crc with
| (Name | Contents _), None -> ifaces
| Name, Some crc -> add_interface (Contents crc)
| Contents old_crc, Some crc ->
if old_crc <> crc then raise (DT.Error (Inconsistent_import name))
else ifaces)
ifaces
(UH.interface_imports ui)
let check_implementation_imports filename ui implems =
List.iter (fun (name, crc) ->
match String.Map.find name implems with
| exception Not_found -> raise (DT.Error (Unavailable_unit name))
| ((old_crc, _old_src, unit_state) : implem) ->
begin match old_crc, crc with
| (None | Some _), None -> ()
| None, Some _crc ->
(* The [None] behaves like a CRC different from every other. *)
raise (DT.Error (Inconsistent_implementation name))
| Some old_crc, Some crc ->
if old_crc <> crc then begin
raise (DT.Error (Inconsistent_implementation name))
end
end;
match unit_state with
| Not_initialized ->
raise (DT.Error (Linking_error (
filename, Uninitialized_global name)))
| Check_inited i ->
if P.num_globals_inited () < i then begin
raise (DT.Error (Linking_error (
filename, Uninitialized_global name)))
end
| Loaded -> ())
(UH.implementation_imports ui)
let check_name filename ui priv ifaces implems =
let name = UH.name ui in
if String.Map.mem name implems then begin
raise (DT.Error (Module_already_loaded name))
end;
if priv && String.Map.mem name ifaces then begin
raise (DT.Error (Private_library_cannot_implement_interface name))
end;
String.Map.add name (UH.crc ui, filename, DT.Not_initialized) implems
let check_unsafe_module ui =
if (not !unsafe_allowed) && UH.unsafe_module ui then begin
raise (DT.Error Unsafe_file)
end
let check filename (units : UH.t list) (state : State.t) ~priv =
List.iter (fun ui -> check_unsafe_module ui) units;
let new_units =
String.Set.of_list (List.map (fun ui -> UH.name ui) units)
in
let implems =
List.fold_left (fun implems ui ->
check_name filename ui priv state.ifaces implems)
state.implems units
in
let allowed_units = String.Set.union state.allowed_units new_units in
let ifaces =
List.fold_left (fun ifaces ui ->
check_interface_imports filename ui ifaces
~allowed_units:allowed_units)
state.ifaces units
in
List.iter (fun ui -> check_implementation_imports filename ui implems)
units;
let defined_symbols =
List.fold_left (fun defined_symbols ui ->
let descr =
lazy (Printf.sprintf "between the executable file (and any \
existing dynamically-loaded units) and the unit `%s' being \
dynamically loaded from %s"
(UH.name ui)
filename)
in
let symbols = String.Set.of_list (UH.defined_symbols ui) in
check_symbols_disjoint ~descr symbols defined_symbols;
String.Set.union symbols defined_symbols)
state.defined_symbols
units
in
if priv then begin
state
end else begin
let public_dynamically_loaded_units =
String.Set.union state.public_dynamically_loaded_units new_units
in
let state =
{ state with
implems;
ifaces;
defined_symbols;
allowed_units;
public_dynamically_loaded_units;
}
in
State.invariant state;
state
end
let set_allowed_units allowed_units =
let allowed_units = String.Set.of_list allowed_units in
let state =
{ !global_state with
allowed_units;
}
in
global_state := state
let allow_only units =
let allowed_units =
String.Set.inter (!global_state).allowed_units
(String.Set.of_list units)
in
let state =
{ !global_state with
allowed_units;
}
in
global_state := state
let prohibit units =
let allowed_units =
String.Set.diff (!global_state).allowed_units
(String.Set.of_list units)
in
let state =
{ !global_state with
allowed_units;
}
in
global_state := state
let main_program_units () =
String.Set.elements (!global_state).main_program_units
let public_dynamically_loaded_units () =
String.Set.elements (!global_state).public_dynamically_loaded_units
let all_units () =
String.Set.elements (String.Set.union
(!global_state).main_program_units
(!global_state).public_dynamically_loaded_units)
let dll_filename fname =
if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
else fname
let set_loaded filename units (state : State.t) =
let implems =
List.fold_left (fun implems ui ->
String.Map.add (UH.name ui) (UH.crc ui, filename, DT.Loaded)
implems)
state.implems
units
in
{ state with implems; }
let run_units handle priv units =
List.iter (fun unit_header -> P.run handle ~unit_header ~priv) units
let load priv filename =
init ();
let filename = dll_filename filename in
match P.load ~filename ~priv with
| exception exn -> raise (DT.Error (Cannot_open_dynamic_library exn))
| handle, units ->
try
global_state := check filename units !global_state ~priv;
run_units handle priv units;
if not priv then begin
global_state := set_loaded filename units !global_state
end;
P.finish handle
with exn ->
P.finish handle;
raise exn
let loadfile filename = load false filename
let loadfile_private filename = load true filename
let is_native = P.is_native
let adapt_filename = P.adapt_filename
end

34
otherlibs/dynlink/dynlink_common.mli Normal file
View File

@ -0,0 +1,34 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-30-40-41-42"]
(** Construction of dynlink functionality given the platform-specific code. *)
module Make (P : Dynlink_platform_intf.S) : sig
val is_native : bool
val loadfile : string -> unit
val loadfile_private : string -> unit
val adapt_filename : string -> string
val set_allowed_units : string list -> unit
val allow_only: string list -> unit
val prohibit : string list -> unit
val main_program_units : unit -> string list
val public_dynamically_loaded_units : unit -> string list
val all_units : unit -> string list
val allow_unsafe_modules : bool -> unit
end

66
otherlibs/dynlink/dynlink_platform_intf.ml Normal file
View File

@ -0,0 +1,66 @@
#2 "otherlibs/dynlink/dynlink_platform_intf.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Interface for platform-specific dynlink providers.
Note that this file needs to be a valid .mli file. *)
[@@@ocaml.warning "+a-4-30-40-41-42"]
module type S = sig
type handle
module Unit_header : sig
type t
val name : t -> string
val crc : t -> Digest.t option
val interface_imports : t -> (string * Digest.t option) list
val implementation_imports : t -> (string * Digest.t option) list
val defined_symbols : t -> string list
val unsafe_module : t -> bool
end
val init : unit -> unit
val is_native : bool
val adapt_filename : Dynlink_types.filename -> Dynlink_types.filename
val num_globals_inited : unit -> int
val fold_initial_units
: init:'a
-> f:('a
-> comp_unit:string
-> interface:Digest.t option
-> implementation:(Digest.t option * Dynlink_types.implem_state) option
-> defined_symbols:string list
-> 'a)
-> 'a
val load
: filename:Dynlink_types.filename
-> priv:bool
-> handle * (Unit_header.t list)
val run : handle -> unit_header:Unit_header.t -> priv:bool -> unit
val finish : handle -> unit
end

116
otherlibs/dynlink/dynlink_types.ml Normal file
View File

@ -0,0 +1,116 @@
#2 "otherlibs/dynlink/dynlink_types.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Types shared amongst the various parts of the dynlink code. *)
[@@@ocaml.warning "+a-4-30-40-41-42"]
type implem_state =
| Loaded
| Not_initialized
| Check_inited of int
type filename = string
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
| Cannot_open_dynamic_library of exn
| Library's_module_initializers_failed of exn
| Inconsistent_implementation of string
| Module_already_loaded of string
| Private_library_cannot_implement_interface of string
exception Error of error
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
| Cannot_open_dynamic_library exn ->
"error loading shared library: " ^ (Printexc.to_string exn)
| Inconsistent_implementation name ->
"implementation mismatch on " ^ name
| Library's_module_initializers_failed exn ->
"execution of module initializers in the shared library failed: "
^ (Printexc.to_string exn)
| Module_already_loaded name ->
"The module `" ^ name ^ "' is already loaded \
(either by the main program or a previously-dynlinked library)"
| Private_library_cannot_implement_interface name ->
"The interface `" ^ name ^ "' cannot be implemented by a \
library loaded privately"
let () =
Printexc.register_printer (function
| Error err ->
let msg = match err with
| Not_a_bytecode_file s -> Printf.sprintf "Not_a_bytecode_file %S" s
| Inconsistent_import s -> Printf.sprintf "Inconsistent_import %S" s
| Unavailable_unit s -> Printf.sprintf "Unavailable_unit %S" s
| Unsafe_file -> "Unsafe_file"
| Linking_error (s, Undefined_global s') ->
Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)"
s s'
| Linking_error (s, Unavailable_primitive s') ->
Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive %S)"
s s'
| Linking_error (s, Uninitialized_global s') ->
Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global %S)"
s s'
| Corrupted_interface s ->
Printf.sprintf "Corrupted_interface %S" s
| Cannot_open_dynamic_library exn ->
Printf.sprintf "Cannot_open_dll %S" (Printexc.to_string exn)
| Inconsistent_implementation s ->
Printf.sprintf "Inconsistent_implementation %S" s
| Library's_module_initializers_failed exn ->
Printf.sprintf "Library's_module_initializers_failed %S"
(Printexc.to_string exn)
| Module_already_loaded name ->
Printf.sprintf "Module_already_loaded %S" name
| Private_library_cannot_implement_interface name ->
Printf.sprintf "Private_library_cannot_implement_interface %S" name
in
Some (Printf.sprintf "Dynlink.Error (Dynlink.%s)" msg)
| _ -> None)

48
driver/compdynlink.mlno → otherlibs/dynlink/dynlink_types.mli
View File

@ -1,12 +1,13 @@
#2 "driver/compdynlink.mlno"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
@ -14,44 +15,35 @@
(* *)
(**************************************************************************)
(* Dynamic loading of .cmx files *)
(** Types shared amongst the various parts of the dynlink code. *)
[@@@ocaml.warning "+a-4-30-40-41-42"]
type implem_state =
| Loaded
| Not_initialized
| Check_inited of int
type filename = string
type linking_error =
Undefined_global of string
| Undefined_global of string
| Unavailable_primitive of string
| Uninitialized_global of string
type error =
Not_a_bytecode_file of string
| 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
| Cannot_open_dynamic_library of exn
| Library's_module_initializers_failed of exn
| Inconsistent_implementation of string
| Module_already_loaded of string
| Private_library_cannot_implement_interface of string
exception Error of error
let not_available _ =
failwith "No support for native dynlink on this OS"
let default_available_units = not_available
let init = not_available
let loadfile = not_available
let loadfile_private = not_available
let allow_only = not_available
let prohibit = not_available
let digest_interface = not_available
let add_interfaces = not_available
let add_available_units = not_available
let clear_available_units = not_available
let allow_unsafe_modules = not_available
let error_message = not_available
let is_native = true
let adapt_filename f = Filename.chop_extension f ^ ".cmxs"
val error_message : error -> string

39
otherlibs/dynlink/extract_crc.ml
View File

@ -18,9 +18,41 @@
let load_path = ref []
let first = ref true
exception Corrupted_interface
let digest_interface unit loadpath =
let filename =
let shortname = unit ^ ".cmi" in
try
Misc.find_in_path_uncap loadpath shortname
with Not_found ->
failwith (Printf.sprintf "Cannot find interface %s in load path"
shortname)
in
let ic = open_in_bin filename in
try
let buffer =
really_input_string ic (String.length Config.cmi_magic_number)
in
if buffer <> Config.cmi_magic_number then begin
close_in ic;
raise Corrupted_interface
end;
let cmi = Cmi_format.input_cmi ic in
close_in ic;
let crc =
match cmi.Cmi_format.cmi_crcs with
(_, Some crc) :: _ -> crc
| _ -> raise Corrupted_interface
in
crc
with End_of_file | Failure _ ->
close_in ic;
raise Corrupted_interface
let print_crc unit =
try
let crc = Dynlink.digest_interface unit (!load_path @ ["."]) in
let crc = digest_interface unit (!load_path @ ["."]) in
if !first then first := false else print_string ";\n";
print_string " \""; print_string (String.capitalize_ascii unit);
print_string "\",\n \"";
@ -33,9 +65,8 @@ let print_crc unit =
prerr_endline unit;
begin match exn with
Sys_error msg -> prerr_endline msg
| Dynlink.Error(Dynlink.File_not_found name) ->
prerr_string "Cannot find file "; prerr_endline name
| Dynlink.Error _ -> prerr_endline "Ill-formed .cmi file"
| Corrupted_interface ->
Printf.eprintf "Ill-formed .cmi file (%s)\n" (Printexc.to_string exn)
| _ -> raise exn
end;
exit 2

308
otherlibs/dynlink/natdynlink.ml
View File

@ -1,12 +1,14 @@
#2 "otherlibs/dynlink/natdynlink.ml"
#3 "otherlibs/dynlink/natdynlink.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
@ -16,241 +18,103 @@
(* Dynamic loading of .cmx files *)
open Cmx_format
[@@@ocaml.warning "+a-4-30-40-41-42"]
type handle
module DC = Dynlink_common
module DT = Dynlink_types
type global_map = {
name : string;
crc_intf : Digest.t;
crc_impl : Digest.t;
crc_intf : Digest.t option;
crc_impl : Digest.t option;
syms : string list
}
external ndl_open: string -> bool -> handle * dynheader = "caml_natdynlink_open"
external ndl_run: handle -> string -> unit = "caml_natdynlink_run"
external ndl_getmap: unit -> global_map list = "caml_natdynlink_getmap"
external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
module Native = struct
type handle
type linking_error =
Undefined_global of string
external ndl_open : string -> bool -> handle * Cmx_format.dynheader
= "caml_natdynlink_open"
external ndl_run : handle -> string -> unit = "caml_natdynlink_run"
external ndl_getmap : unit -> global_map list = "caml_natdynlink_getmap"
external ndl_globals_inited : unit -> int = "caml_natdynlink_globals_inited"
module Unit_header = struct
type t = Cmx_format.dynunit
let name (t : t) = t.dynu_name
let crc (t : t) = Some t.dynu_crc
let interface_imports (t : t) = t.dynu_imports_cmi
let implementation_imports (t : t) = t.dynu_imports_cmx
let defined_symbols (t : t) = t.dynu_defines
let unsafe_module _t = false
end
let init () = ()
let is_native = true
let adapt_filename f = Filename.chop_extension f ^ ".cmxs"
let num_globals_inited () = ndl_globals_inited ()
(* Copied from config.ml -- this file cannot depend on that. *)
let cmxs_magic_number = "Caml1999D023"
let fold_initial_units ~init ~f =
let rank = ref 0 in
List.fold_left (fun acc { name; crc_intf; crc_impl; syms; } ->
rank := !rank + List.length syms;
let implementation =
match crc_impl with
| None -> None
| Some _ as crco -> Some (crco, DT.Check_inited !rank)
in
f acc ~comp_unit:name ~interface:crc_intf
~implementation ~defined_symbols:syms)
init
(ndl_getmap ())
let run handle ~unit_header ~priv:_ =
ndl_run handle "_shared_startup";
List.iter (fun cu ->
try ndl_run handle cu
with exn -> raise (DT.Error (Library's_module_initializers_failed exn)))
(Unit_header.defined_symbols unit_header)
let load ~filename ~priv =
let handle, header =
try ndl_open filename (not priv)
with exn -> raise (DT.Error (Cannot_open_dynamic_library exn))
in
if header.dynu_magic <> cmxs_magic_number then begin
raise (DT.Error (Not_a_bytecode_file filename))
end;
handle, header.dynu_units
let finish _handle = ()
end
include DC.Make (Native)
type linking_error = DT.linking_error =
| Undefined_global of string
| Unavailable_primitive of string
| Uninitialized_global of string
type error =
Not_a_bytecode_file of string
type error = DT.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
| Cannot_open_dynamic_library of exn
| Library's_module_initializers_failed of exn
| Inconsistent_implementation of string
| Module_already_loaded of string
| Private_library_cannot_implement_interface of string
exception Error of error
(* Copied from config.ml to avoid dependencies *)
let cmxs_magic_number = "Caml1999D023"
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,header) = try
ndl_open dll (not priv)
with Failure s -> raise (Error (Cannot_open_dll s)) 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 = ndl_getmap () 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, crco) ->
match crco with
None -> ifaces
| Some 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 ui implems =
List.iter
(fun (name, crco) ->
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
match crco with
Some crc when old_crc <> crc ->
raise(Error(Inconsistent_implementation name))
| _ ->
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 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"
exception Error = DT.Error
let error_message = DT.error_message

55
otherlibs/dynlink/nodynlink.ml Normal file
View File

@ -0,0 +1,55 @@
#2 "otherlibs/dynlink/nodynlink.ml"
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* Copyright 2017--2018 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
[@@@ocaml.warning "+a-4-30-40-41-42"]
module DC = Dynlink_common
let not_available () =
failwith "No support for native dynlink on this platform"
module Not_available = struct
module Unit_header = struct
type t = unit
let defines _ = not_available ()
let unsafe_module _ = not_available ()
end
type handle = unit
let default_crcs = ref []
let init () = not_available ()
let is_native = false
let adapt_filename f = f
let iter_initial_units _ = ()
let run _ ~unit_header:_ ~priv:_ = not_available ()
let load ~filename:_ ~priv:_ = not_available ()
let finish _ = not_available ()
end
include DC.Make (Not_available)
type linking_error = DC.linking_error
type error = DC.error
exception Error = DC.Error
let error_message = DC.error

1
testsuite/tests/lib-dynlink-bytecode/main.ml
View File

@ -60,7 +60,6 @@ let f x = print_string "This is Main.f\n"; x
let () = Registry.register f
let _ =
Dynlink.init ();
Dynlink.allow_unsafe_modules true;
for i = 1 to Array.length Sys.argv - 1 do
let name = Sys.argv.(i) in

1
testsuite/tests/lib-dynlink-csharp/main.ml
View File

@ -94,7 +94,6 @@ let _ = Stdlib.Bigarray.float32
let () =
ignore (Hashtbl.hash 42.0);
print_endline "Main is running.";
Dynlink.init ();
Dynlink.allow_unsafe_modules true;
let plugin_name = Dynlink.adapt_filename "plugin.cmo" in
load plugin_name;

2
testsuite/tests/lib-dynlink-initializers/ocamltests Normal file
View File

@ -0,0 +1,2 @@
test1_main.ml
test2_main.ml

1
testsuite/tests/lib-dynlink-initializers/test1_inited_second.ml Normal file
View File

@ -0,0 +1 @@
let g x = Test1_main.f x

56
testsuite/tests/lib-dynlink-initializers/test1_main.ml Normal file
View File

@ -0,0 +1,56 @@
(* TEST
include dynlink
files = "test1_inited_second.ml test1_plugin.ml"
libraries = ""
* shared-libraries
** setup-ocamlc.byte-build-env
*** ocamlc.byte
module = "test1_main.ml"
*** ocamlc.byte
module = "test1_inited_second.ml"
*** ocamlc.byte
module = "test1_plugin.ml"
*** ocamlc.byte
program = "${test_build_directory}/test1.byte"
libraries = "dynlink"
all_modules = "test1_main.cmo test1_inited_second.cmo"
**** run
** native-dynlink
*** setup-ocamlopt.byte-build-env
**** ocamlopt.byte
module = "test1_main.ml"
**** ocamlopt.byte
module = "test1_inited_second.ml"
**** ocamlopt.byte
program = "test1_plugin.cmxs"
flags = "-shared"
all_modules = "test1_plugin.ml"
**** ocamlopt.byte
program = "${test_build_directory}/test1.exe"
libraries = "dynlink"
all_modules = "test1_main.cmx test1_inited_second.cmx"
***** run
*)
(* Check that a module in the main program whose initializer has not
executed completely cannot be depended upon by a shared library being
loaded. *)
let f x = x + 1 [@@inline never]
let () =
try
if Dynlink.is_native then
Dynlink.loadfile "test1_plugin.cmxs"
else
Dynlink.loadfile "test1_plugin.cmo"
with
| Dynlink.Error (
Dynlink.Linking_error (_,
Dynlink.Uninitialized_global "Test1_inited_second")) -> ()
| exn -> raise exn

2
testsuite/tests/lib-dynlink-initializers/test1_plugin.ml Normal file
View File

@ -0,0 +1,2 @@
let () =
print_int ((Test1_inited_second.g [@inlined never]) 42)

50
testsuite/tests/lib-dynlink-initializers/test2_main.ml Normal file
View File

@ -0,0 +1,50 @@
(* TEST
include dynlink
files = "test2_plugin.ml test2_second_plugin.ml"
libraries = ""
* shared-libraries
** setup-ocamlc.byte-build-env
*** ocamlc.byte
module = "test2_main.ml"
*** ocamlc.byte
module = "test2_plugin.ml"
*** ocamlc.byte
module = "test2_second_plugin.ml"
*** ocamlc.byte
program = "${test_build_directory}/test2.byte"
libraries = "dynlink"
all_modules = "test2_main.cmo"
**** run
** native-dynlink
*** setup-ocamlopt.byte-build-env
**** ocamlopt.byte
module = "test2_main.ml"
**** ocamlopt.byte
program = "test2_plugin.cmxs"
flags = "-shared"
all_modules = "test2_plugin.ml"
**** ocamlopt.byte
program = "test2_second_plugin.cmxs"
flags = "-shared"
all_modules = "test2_second_plugin.ml"
**** ocamlopt.byte
program = "${test_build_directory}/test2.exe"
libraries = "dynlink"
all_modules = "test2_main.cmx"
***** run
*)
(* Check that a module in a loaded shared library whose initializer has not
executed completely cannot be depended upon by another shared library being
loaded. *)
let () =
if Dynlink.is_native then
Dynlink.loadfile "test2_plugin.cmxs"
else
Dynlink.loadfile "test2_plugin.cmo"

16
testsuite/tests/lib-dynlink-initializers/test2_plugin.ml Normal file
View File

@ -0,0 +1,16 @@
let x = ref 0
let () =
try
if Dynlink.is_native then
Dynlink.loadfile "test2_second_plugin.cmxs"
else
Dynlink.loadfile "test2_second_plugin.cmo"
with
| Dynlink.Error (
Dynlink.Linking_error (_,
Dynlink.Uninitialized_global "Test2_plugin")) -> ()
| _ -> exit 1
let () =
x := 1

2
testsuite/tests/lib-dynlink-initializers/test2_second_plugin.ml Normal file
View File

@ -0,0 +1,2 @@
let () =
assert (!Test2_plugin.x = 1)

1
testsuite/tests/lib-dynlink-native/main.ml
View File

@ -215,7 +215,6 @@ let () =
Api.add_cb (fun () -> print_endline "Callback from main")
let () =
Dynlink.init ();
Dynlink.allow_unsafe_modules true;
for i = 1 to Array.length Sys.argv - 1 do
let name = Sys.argv.(i) in

3
testsuite/tests/lib-dynlink-pr4229/abstract.ml Normal file
View File

@ -0,0 +1,3 @@
type t = int
let print i = Printf.printf "Abstract %i\n" i
let x = 10

3
testsuite/tests/lib-dynlink-pr4229/abstract.mli Normal file
View File

@ -0,0 +1,3 @@
type t
val print: t -> unit
val x: t

1
testsuite/tests/lib-dynlink-pr4229/client.ml Normal file
View File

@ -0,0 +1 @@
let () = Static.f Abstract.x

94
testsuite/tests/lib-dynlink-pr4229/main.ml Normal file
View File

@ -0,0 +1,94 @@
(* TEST
include dynlink
files = "abstract.mli abstract.ml static.ml client.ml main.ml"
set sub = "${test_source_directory}/sub"
libraries = ""
* shared-libraries
** setup-ocamlc.byte-build-env
*** script
script = "mkdir sub"
**** script
script = "cp ${sub}/abstract.mli ${sub}/abstract.ml sub"
***** cd
cwd = "${sub}"
****** ocamlc.byte
module = "abstract.mli"
******* ocamlc.byte
module = "abstract.ml"
******** cd
cwd = ".."
********* ocamlc.byte
module = "abstract.mli"
********** ocamlc.byte
module = "abstract.ml"
*********** ocamlc.byte
module = "static.ml"
************ ocamlc.byte
module = "client.ml"
************* ocamlc.byte
module = "main.ml"
************** ocamlc.byte
program = "${test_build_directory}/main"
libraries = "dynlink"
module = ""
all_modules = "abstract.cmo static.cmo main.cmo"
*************** run
exit_status = "2"
**************** check-program-output
** native-dynlink
*** setup-ocamlopt.byte-build-env
**** script
script = "mkdir sub"
***** script
script = "cp ${sub}/abstract.mli ${sub}/abstract.ml sub"
****** cd
cwd = "${sub}"
******* ocamlopt.byte
module = "abstract.mli"
******** ocamlopt.byte
program = "abstract.cmxs"
flags = "-shared"
module = ""
all_modules = "abstract.ml"
********* cd
cwd = ".."
********** ocamlopt.byte
flags = ""
module = "abstract.mli"
*********** ocamlopt.byte
module = "abstract.ml"
************ ocamlopt.byte
module = "static.ml"
************* ocamlopt.byte
program = "client.cmxs"
flags = "-shared"
module = ""
all_modules = "client.ml"
************* ocamlopt.byte
module = "main_native.ml"
************** ocamlopt.byte
program = "${test_build_directory}/main_native"
libraries = "dynlink"
module = ""
all_modules = "abstract.cmx static.cmx main_native.cmx"
*************** run
exit_status = "2"
**************** check-program-output
*)
(* PR#4229 *)
let () =
try
(* Dynlink.init (); *) (* this function has been removed from the API *)
Dynlink.loadfile "client.cmo"; (* utilise abstract.cmo *)
Dynlink.loadfile "sub/abstract.cmo";
Dynlink.loadfile "client.cmo" (* utilise sub/abstract.cmo *)
with
| Dynlink.Error (Dynlink.Module_already_loaded "Abstract") -> exit 2

1
testsuite/tests/lib-dynlink-pr4229/main.reference Normal file
View File

@ -0,0 +1 @@
Abstract 10

10
testsuite/tests/lib-dynlink-pr4229/main_native.ml Normal file
View File

@ -0,0 +1,10 @@
(* PR#4229 *)
let () =
try
(* Dynlink.init (); *) (* this function has been removed from the API *)
Dynlink.loadfile "client.cmxs"; (* utilise abstract.cmx *)
Dynlink.loadfile "sub/abstract.cmxs";
Dynlink.loadfile "client.cmxs" (* utilise sub/abstract.cmx *)
with
| Dynlink.Error (Dynlink.Module_already_loaded "Abstract") -> exit 2

1
testsuite/tests/lib-dynlink-pr4229/ocamltests Normal file
View File

@ -0,0 +1 @@
main.ml

1
testsuite/tests/lib-dynlink-pr4229/static.ml Normal file
View File

@ -0,0 +1 @@
let f = Abstract.print

3
testsuite/tests/lib-dynlink-pr4229/sub/abstract.ml Normal file
View File

@ -0,0 +1,3 @@
type t = string
let print i = Printf.printf "Abstract %s\n" i
let x = "foo"

3
testsuite/tests/lib-dynlink-pr4229/sub/abstract.mli Normal file
View File

@ -0,0 +1,3 @@
type t
val print: t -> unit
val x: t

3
testsuite/tests/lib-dynlink-pr4839/byte.plugin1.reference Normal file
View File

@ -0,0 +1,3 @@
API
zero=0
fact (zero+5) = 120

2
testsuite/tests/lib-dynlink-pr4839/byte.plugin2.reference Normal file
View File

@ -0,0 +1,2 @@
API
ERROR: interface mismatch on Packed

2
testsuite/tests/lib-dynlink-pr4839/byte.plugin3.reference Normal file
View File

@ -0,0 +1,2 @@
API
ERROR: The module `Packed' is already loaded (either by the main program or a previously-dynlinked library)

2
testsuite/tests/lib-dynlink-pr4839/byte.plugin4.reference Normal file
View File

@ -0,0 +1,2 @@
API
ERROR: The module `Packed' is already loaded (either by the main program or a previously-dynlinked library)

3
testsuite/tests/lib-dynlink-pr4839/host/api.ml Normal file
View File

@ -0,0 +1,3 @@
let fact = ref (fun _ -> assert false)
let zero = ref (-1)
let _ = prerr_endline "API"

2
testsuite/tests/lib-dynlink-pr4839/host/api.mli Normal file
View File

@ -0,0 +1,2 @@
val fact : (int -> int) ref
val zero : int ref

8
testsuite/tests/lib-dynlink-pr4839/host/host.ml Normal file
View File

@ -0,0 +1,8 @@
let _ =
try
Dynlink.loadfile Sys.argv.(1);
Format.eprintf "zero=%d@." !Packed.Api.zero;
Format.eprintf "fact (zero+5) = %d@." (!Packed.Api.fact (!Packed.Api.zero + 5))
with
| Dynlink.Error e ->
Format.eprintf "ERROR: %s@." (Dynlink.error_message e)

3
testsuite/tests/lib-dynlink-pr4839/native.plugin1.reference Normal file
View File

@ -0,0 +1,3 @@
API
zero=0
fact (zero+5) = 120

2
testsuite/tests/lib-dynlink-pr4839/native.plugin2.reference Normal file
View File

@ -0,0 +1,2 @@
API
ERROR: interface mismatch on Packed

2
testsuite/tests/lib-dynlink-pr4839/native.plugin3.reference Normal file
View File

@ -0,0 +1,2 @@
API
ERROR: The module `Packed' is already loaded (either by the main program or a previously-dynlinked library)

2
testsuite/tests/lib-dynlink-pr4839/native.plugin4.reference Normal file
View File

@ -0,0 +1,2 @@
API
ERROR: The module `Packed' is already loaded (either by the main program or a previously-dynlinked library)

1
testsuite/tests/lib-dynlink-pr4839/ocamltests Normal file
View File

@ -0,0 +1 @@
test.ml

3
testsuite/tests/lib-dynlink-pr4839/plugin1/api.ml Normal file
View File

@ -0,0 +1,3 @@
let fact = ref (fun _ -> assert false)
let zero = ref (-1)
let _ = prerr_endline "API"

2
testsuite/tests/lib-dynlink-pr4839/plugin1/api.mli Normal file
View File

@ -0,0 +1,2 @@
val fact : (int -> int) ref
val zero : int ref

7
testsuite/tests/lib-dynlink-pr4839/plugin1/plugin.ml Normal file
View File

@ -0,0 +1,7 @@
let rec fact = function
| 0 -> 1
| n -> n * fact (n - 1)
let _ =
Packed.Api.zero := 0;
Packed.Api.fact := fact

3
testsuite/tests/lib-dynlink-pr4839/plugin2/api.ml Normal file
View File

@ -0,0 +1,3 @@
let fact = ref None
let zero = ref (-1)
let _ = prerr_endline "API"

2
testsuite/tests/lib-dynlink-pr4839/plugin2/api.mli Normal file
View File

@ -0,0 +1,2 @@
val fact : (int -> int) option ref
val zero : int ref

7
testsuite/tests/lib-dynlink-pr4839/plugin2/plugin.ml Normal file
View File

@ -0,0 +1,7 @@
let rec fact = function
| 0 -> 1
| n -> n * fact (n - 1)
let _ =
Packed.Api.zero := 0;
Packed.Api.fact := Some fact

3
testsuite/tests/lib-dynlink-pr4839/plugin3/api.ml Normal file
View File

@ -0,0 +1,3 @@
let fact = ref None
let zero = ref (-1)
let _ = prerr_endline "API"

2
testsuite/tests/lib-dynlink-pr4839/plugin3/api.mli Normal file
View File

@ -0,0 +1,2 @@
val fact : (int -> int) option ref
val zero : int ref

7
testsuite/tests/lib-dynlink-pr4839/plugin3/plugin.ml Normal file
View File

@ -0,0 +1,7 @@
let rec fact = function
| 0 -> 1
| n -> n * fact (n - 1)
let _ =
Packed.Api.zero := 0;
Packed.Api.fact := Some fact

3
testsuite/tests/lib-dynlink-pr4839/plugin4/api.ml Normal file
View File

@ -0,0 +1,3 @@
let fact = ref (fun _ -> assert false)
let zero = ref 42
let _ = prerr_endline "API"

2
testsuite/tests/lib-dynlink-pr4839/plugin4/api.mli Normal file
View File

@ -0,0 +1,2 @@
val fact : (int -> int) ref
val zero : int ref

7
testsuite/tests/lib-dynlink-pr4839/plugin4/plugin.ml Normal file
View File

@ -0,0 +1,7 @@
let rec fact = function
| 0 -> 1
| n -> n * fact (n - 1)
let _ =
(* Packed.Api.zero := 0; *)
Packed.Api.fact := fact

261
testsuite/tests/lib-dynlink-pr4839/test.ml Normal file
View File

@ -0,0 +1,261 @@
(* TEST
include dynlink
libraries = ""
set host = "${test_source_directory}/host"
set plugin1 = "${test_source_directory}/plugin1"
set plugin2 = "${test_source_directory}/plugin2"
set plugin3 = "${test_source_directory}/plugin3"
set plugin4 = "${test_source_directory}/plugin4"
* shared-libraries
** setup-ocamlc.byte-build-env
*** script
script = "mkdir host plugin1 plugin2 plugin3 plugin4"
*** script
script = "cp ${host}/host.ml ${host}/api.mli ${host}/api.ml host"
*** script
script = "cp ${plugin1}/plugin.ml ${plugin1}/api.mli ${plugin1}/api.ml plugin1"
*** script
script = "cp ${plugin2}/plugin.ml ${plugin2}/api.mli ${plugin2}/api.ml plugin2"
*** script
script = "cp ${plugin3}/plugin.ml ${plugin3}/api.mli ${plugin3}/api.ml plugin3"
*** script
script = "cp ${plugin4}/plugin.ml ${plugin4}/api.mli ${plugin4}/api.ml plugin4"
*** cd
cwd = "plugin1"
*** ocamlc.byte
module = "api.mli"
*** ocamlc.byte
flags = "-for-pack Packed"
module = "api.ml"
*** ocamlc.byte
program = "packed.cmo"
flags = "-pack"
all_modules = "api.cmo"
*** ocamlc.byte
program = "plugin.cma"
flags = "-a"
all_modules = "plugin.ml"
*** cd
cwd = ".."
*** cd
cwd = "plugin2"
*** ocamlc.byte
module = "api.mli"
*** ocamlc.byte
flags = "-for-pack Packed"
module = "api.ml"
*** ocamlc.byte
program = "packed.cmo"
flags = "-pack"
all_modules = "api.cmo"
*** ocamlc.byte
program = "plugin.cma"
flags = "-a"
all_modules = "plugin.ml"
*** cd
cwd = ".."
*** cd
cwd = "plugin3"
*** ocamlc.byte
module = "api.mli"
*** ocamlc.byte
flags = "-for-pack Packed"
module = "api.ml"
*** ocamlc.byte
program = "packed.cmo"
flags = "-pack"
all_modules = "api.cmo"
*** ocamlc.byte
program = "plugin.cma"
flags = "-a"
all_modules = "packed.cmo plugin.ml"
*** cd
cwd = ".."
*** cd
cwd = "plugin4"
*** ocamlc.byte
module = "api.mli"
*** ocamlc.byte
flags = "-for-pack Packed"
module = "api.ml"
*** ocamlc.byte
program = "packed.cmo"
flags = "-pack"
all_modules = "api.cmo"
*** ocamlc.byte
program = "plugin.cma"
flags = "-a"
all_modules = "packed.cmo plugin.ml"
*** cd
cwd = ".."
*** cd
cwd = "host"
*** ocamlc.byte
module = "api.mli"
*** ocamlc.byte
flags = "-for-pack Packed"
module = "api.ml"
*** ocamlc.byte
program = "packed.cmo"
flags = "-pack"
all_modules = "api.cmo"
*** ocamlc.byte
program = "./host.byt"
libraries = "dynlink"
all_modules = "packed.cmo host.ml"
**** run
arguments = "../plugin1/plugin.cma"
output = "byte.plugin1.result"
***** check-program-output
reference = "${test_source_directory}/byte.plugin1.reference"
**** run
arguments = "../plugin2/plugin.cma"
output = "byte.plugin2.result"
***** check-program-output
reference = "${test_source_directory}/byte.plugin2.reference"
**** run
arguments = "../plugin3/plugin.cma"
output = "byte.plugin3.result"
***** check-program-output
reference = "${test_source_directory}/byte.plugin3.reference"
**** run
arguments = "../plugin4/plugin.cma"
output = "byte.plugin4.result"
***** check-program-output
reference = "${test_source_directory}/byte.plugin4.reference"
*** cd
cwd = ".."
** native-dynlink
*** setup-ocamlopt.byte-build-env
**** script
script = "mkdir host plugin1 plugin2 plugin3 plugin4"
**** script
script = "cp ${host}/host.ml ${host}/api.mli ${host}/api.ml host"
**** script
script = "cp ${plugin1}/plugin.ml ${plugin1}/api.mli ${plugin1}/api.ml plugin1"
**** script
script = "cp ${plugin2}/plugin.ml ${plugin2}/api.mli ${plugin2}/api.ml plugin2"
**** script
script = "cp ${plugin3}/plugin.ml ${plugin3}/api.mli ${plugin3}/api.ml plugin3"
**** script
script = "cp ${plugin4}/plugin.ml ${plugin4}/api.mli ${plugin4}/api.ml plugin4"
**** cd
cwd = "plugin1"
**** ocamlopt.byte
module = "api.mli"
**** ocamlopt.byte
flags = "-for-pack Packed"
module = "api.ml"
**** ocamlopt.byte
program = "packed.cmx"
flags = "-pack"
all_modules = "api.cmx"
**** ocamlopt.byte
program = "plugin.cmxs"
flags = "-shared"
all_modules = "plugin.ml"
**** cd
cwd = ".."
**** cd
cwd = "plugin2"
**** ocamlopt.byte
module = "api.mli"
**** ocamlopt.byte
flags = "-for-pack Packed"
module = "api.ml"
**** ocamlopt.byte
program = "packed.cmx"
flags = "-pack"
all_modules = "api.cmx"
**** ocamlopt.byte
program = "plugin.cmxs"
flags = "-shared"
all_modules = "plugin.ml"
*** cd
cwd = ".."
**** cd
cwd = "plugin3"
**** ocamlopt.byte
module = "api.mli"
**** ocamlopt.byte
flags = "-for-pack Packed"
module = "api.ml"
**** ocamlopt.byte
program = "packed.cmx"
flags = "-pack"
all_modules = "api.cmx"
**** ocamlopt.byte
program = "plugin.cmxs"
flags = "-shared"
all_modules = "packed.cmx plugin.ml"
**** cd
cwd = ".."
**** cd
cwd = "plugin4"
**** ocamlopt.byte
module = "api.mli"
**** ocamlopt.byte
flags = "-for-pack Packed"
module = "api.ml"
**** ocamlopt.byte
program = "packed.cmx"
flags = "-pack"
all_modules = "api.cmx"
**** ocamlopt.byte
program = "plugin.cmxs"
flags = "-shared"
all_modules = "packed.cmx plugin.ml"
**** cd
cwd = ".."
**** cd
cwd = "host"
**** ocamlopt.byte
module = "api.mli"
**** ocamlopt.byte
flags = "-for-pack Packed"
module = "api.ml"
**** ocamlopt.byte
program = "packed.cmx"
flags = "-pack"
all_modules = "api.cmx"
**** ocamlopt.byte
program = "./host.exe"
libraries = "dynlink"
all_modules = "packed.cmx host.ml"
***** run
arguments = "../plugin1/plugin.cmxs"
output = "native.plugin1.result"
****** check-program-output
reference = "${test_source_directory}/native.plugin1.reference"
***** run
arguments = "../plugin2/plugin.cmxs"
output = "native.plugin2.result"
****** check-program-output
reference = "${test_source_directory}/native.plugin2.reference"
***** run
arguments = "../plugin3/plugin.cmxs"
output = "native.plugin3.result"
****** check-program-output
reference = "${test_source_directory}/native.plugin3.reference"
***** run
arguments = "../plugin4/plugin.cmxs"
output = "native.plugin4.result"
****** check-program-output
reference = "${test_source_directory}/native.plugin4.reference"
**** cd
cwd = ".."
*)

1
testsuite/tests/lib-dynlink-pr6950/b.ml Normal file
View File

@ -0,0 +1 @@
let () = Printf.printf "%s\n%s\n" Config.foo Config.bar

0
testsuite/tests/lib-dynlink-pr6950/byte.reference Normal file
View File

2
testsuite/tests/lib-dynlink-pr6950/config.ml Normal file
View File

@ -0,0 +1,2 @@
let foo = "foo"
let bar = "bar"

48
testsuite/tests/lib-dynlink-pr6950/loader.ml Normal file
View File

@ -0,0 +1,48 @@
(* TEST
include dynlink
libraries = ""
files = "config.ml b.ml"
* shared-libraries
** setup-ocamlc.byte-build-env
*** ocamlc.byte
program = "plugin.cma"
flags = "-a"
all_modules = "config.ml b.ml"
*** ocamlc.byte
program = "${test_build_directory}/loader.byte"
flags = "-linkall"
include ocamlcommon
libraries += "dynlink"
all_modules = "loader.ml"
**** run
arguments = "plugin.cma"
exit_status = "2"
***** check-program-output
reference = "${test_source_directory}/byte.reference"
** native-dynlink
*** setup-ocamlopt.byte-build-env
**** ocamlopt.byte
program = "plugin.cmxs"
flags = "-shared"
all_modules = "config.ml b.ml"
**** ocamlopt.byte
program = "${test_build_directory}/loader.exe"
flags = "-linkall"
include ocamlcommon
libraries += "dynlink"
all_modules = "loader.ml"
***** run
arguments = "plugin.cmxs"
exit_status = "2"
****** check-program-output
reference = "${test_source_directory}/native.reference"
*)
let () =
try
Dynlink.loadfile Sys.argv.(1)
with
| Dynlink.Error (Dynlink.Module_already_loaded "Config") -> exit 2
| _ -> exit 1

0
testsuite/tests/lib-dynlink-pr6950/native.reference Normal file
View File

1
testsuite/tests/lib-dynlink-pr6950/ocamltests Normal file
View File

@ -0,0 +1 @@
loader.ml

14
testsuite/tests/lib-dynlink-pr6950/test.sh Executable file
View File

@ -0,0 +1,14 @@
#!/bin/bash
rm -f *.{cmi,cmx,o,cmxs}
ocamlopt.opt \
-I +compiler-libs ocamlcommon.cmxa dynlink.cmxa -linkall \
loader.ml -o loader.exe
ocamlopt.opt \
-I . \
-shared -o b.cmxs \
config.ml b.ml
./loader.exe b.cmxs

1
testsuite/tests/lib-dynlink-private/ocamltests Normal file
View File

@ -0,0 +1 @@
test.ml

4
testsuite/tests/lib-dynlink-private/pig.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val p : t
val oink : t -> unit

4
testsuite/tests/lib-dynlink-private/plugin1/sheep.ml Normal file
View File

@ -0,0 +1,4 @@
type t = int
let s = 42
let baa _t = () [@@inline never]

4
testsuite/tests/lib-dynlink-private/plugin1/sheep.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val s : t
val baa : t -> unit

4
testsuite/tests/lib-dynlink-private/plugin2/cow.ml Normal file
View File

@ -0,0 +1,4 @@
type t = int
let c = 42
let moo _t = () [@@inline never]

4
testsuite/tests/lib-dynlink-private/plugin2/cow.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val c : t
val moo : t -> unit

4
testsuite/tests/lib-dynlink-private/plugin2b/cow.ml Normal file
View File

@ -0,0 +1,4 @@
type t = int
let c = 1
let moo _t = () [@@inline never]

4
testsuite/tests/lib-dynlink-private/plugin2b/cow.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val c : t
val moo : t -> unit

4
testsuite/tests/lib-dynlink-private/plugin2c/cow.ml Normal file
View File

@ -0,0 +1,4 @@
type t = int
let d = 4
let moo _t = () [@@inline never]

4
testsuite/tests/lib-dynlink-private/plugin2c/cow.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val d : t
val moo : t -> unit

4
testsuite/tests/lib-dynlink-private/plugin3/pig.ml Normal file
View File

@ -0,0 +1,4 @@
type t = string
let p = "oink"
let oink _t = () [@@inline never]

4
testsuite/tests/lib-dynlink-private/plugin3/pig.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val p : t
val oink : t -> unit

11
testsuite/tests/lib-dynlink-private/plugin4/chicken.ml Normal file
View File

@ -0,0 +1,11 @@
(* Test that a privately loaded module can recursively load a module of
the same name *)
let test_chicken () =
if Dynlink.is_native then
Dynlink.loadfile_private "plugin5/chicken.cmxs"
else
Dynlink.loadfile_private "plugin5/chicken.cmo"
let () =
test_chicken ()

0
testsuite/tests/lib-dynlink-private/plugin4/chicken.mli Normal file
View File

2
testsuite/tests/lib-dynlink-private/plugin5/chicken.ml Normal file
View File

@ -0,0 +1,2 @@
let x = 5

2
testsuite/tests/lib-dynlink-private/plugin5/chicken.mli Normal file
View File

@ -0,0 +1,2 @@
val x : int

1
testsuite/tests/lib-dynlink-private/plugin6/partridge.ml Normal file
View File

@ -0,0 +1 @@
let wings = 2

1
testsuite/tests/lib-dynlink-private/plugin6/partridge.mli Normal file
View File

@ -0,0 +1 @@
val wings : int

10
testsuite/tests/lib-dynlink-private/plugin6/pheasant.ml Normal file
View File

@ -0,0 +1,10 @@
(* See comment in the main "test.ml" file. *)
let test_pheasant () =
if Dynlink.is_native then
Dynlink.loadfile "plugin6/partridge.cmxs"
else
Dynlink.loadfile "plugin6/partridge.cmo"
let () =
test_pheasant ()

0
testsuite/tests/lib-dynlink-private/plugin6/pheasant.mli Normal file
View File

4
testsuite/tests/lib-dynlink-private/sheep.ml Normal file
View File

@ -0,0 +1,4 @@
type t = string
let s = "baa"
let baa _t = () [@@inline never]

4
testsuite/tests/lib-dynlink-private/sheep.mli Normal file
View File

@ -0,0 +1,4 @@
type t
val s : t
val baa : t -> unit

272
testsuite/tests/lib-dynlink-private/test.ml Normal file
View File

@ -0,0 +1,272 @@
(* TEST
include dynlink
libraries = ""
files = "sheep.mli sheep.ml pig.mli"
set plugin1 = "${test_source_directory}/plugin1"
set plugin2 = "${test_source_directory}/plugin2"
set plugin2b = "${test_source_directory}/plugin2b"
set plugin2c = "${test_source_directory}/plugin2c"
set plugin3 = "${test_source_directory}/plugin3"
set plugin4 = "${test_source_directory}/plugin4"
set plugin5 = "${test_source_directory}/plugin5"
set plugin6 = "${test_source_directory}/plugin6"
* shared-libraries
** setup-ocamlc.byte-build-env
*** ocamlc.byte
module = "sheep.mli"
**** ocamlc.byte
module = "sheep.ml"
***** ocamlc.byte
module = "pig.mli"
****** ocamlc.byte
module = "test.ml"
*** script
script = "mkdir plugin1 plugin2 plugin2b plugin2c plugin3 plugin4 plugin5 plugin6"
**** script
script = "cp ${plugin1}/sheep.mli ${plugin1}/sheep.ml plugin1"
**** script
script = "cp ${plugin2}/cow.mli ${plugin2}/cow.ml plugin2"
**** script
script = "cp ${plugin2b}/cow.mli ${plugin2b}/cow.ml plugin2b"
**** script
script = "cp ${plugin2c}/cow.mli ${plugin2c}/cow.ml plugin2c"
**** script
script = "cp ${plugin3}/pig.mli ${plugin3}/pig.ml plugin3"
**** script
script = "cp ${plugin4}/chicken.mli ${plugin4}/chicken.ml plugin4"
**** script
script = "cp ${plugin5}/chicken.mli ${plugin5}/chicken.ml plugin5"
**** script
script = "cp ${plugin6}/pheasant.mli ${plugin6}/pheasant.ml ${plugin6}/partridge.mli ${plugin6}/partridge.ml plugin6"
***** ocamlc.byte
module = "plugin1/sheep.mli"
***** ocamlc.byte
flags = "-I plugin1"
module = "plugin1/sheep.ml"
***** ocamlc.byte
module = "plugin2/cow.mli"
***** ocamlc.byte
flags = "-I plugin2"
module = "plugin2/cow.ml"
***** ocamlc.byte
module = "plugin2b/cow.mli"
***** ocamlc.byte
flags = "-I plugin2b"
module = "plugin2b/cow.ml"
***** ocamlc.byte
module = "plugin2c/cow.mli"
***** ocamlc.byte
flags = "-I plugin2c"
module = "plugin2c/cow.ml"
***** ocamlc.byte
module = "plugin3/pig.mli"
***** ocamlc.byte
flags = "-I plugin3"
module = "plugin3/pig.ml"
***** ocamlc.byte
module = "plugin4/chicken.mli"
***** ocamlc.byte
flags = "-I plugin4"
module = "plugin4/chicken.ml"
***** ocamlc.byte
module = "plugin5/chicken.mli"
***** ocamlc.byte
flags = "-I plugin5"
module = "plugin5/chicken.ml"
***** ocamlc.byte
module = "plugin6/pheasant.mli"
***** ocamlc.byte
flags = "-I plugin6"
module = "plugin6/pheasant.ml"
***** ocamlc.byte
module = "plugin6/partridge.mli"
***** ocamlc.byte
flags = "-I plugin6"
module = "plugin6/partridge.ml"
***** ocamlc.byte
program = "${test_build_directory}/test.byte"
libraries = "dynlink"
all_modules = "sheep.cmo test.cmo"
****** run
** native-dynlink
*** setup-ocamlopt.byte-build-env
**** ocamlopt.byte
module = "sheep.mli"
***** ocamlopt.byte
module = "sheep.ml"
****** ocamlopt.byte
module = "pig.mli"
******* ocamlopt.byte
module = "test.ml"
**** script
script = "mkdir plugin1 plugin2 plugin2b plugin2c plugin3 plugin4 plugin5 plugin6"
***** script
script = "cp ${plugin1}/sheep.mli ${plugin1}/sheep.ml plugin1"
***** script
script = "cp ${plugin2}/cow.mli ${plugin2}/cow.ml plugin2"
***** script
script = "cp ${plugin2b}/cow.mli ${plugin2b}/cow.ml plugin2b"
***** script
script = "cp ${plugin2c}/cow.mli ${plugin2c}/cow.ml plugin2c"
***** script
script = "cp ${plugin3}/pig.mli ${plugin3}/pig.ml plugin3"
***** script
script = "cp ${plugin4}/chicken.mli ${plugin4}/chicken.ml plugin4"
***** script
script = "cp ${plugin5}/chicken.mli ${plugin5}/chicken.ml plugin5"
***** script
script = "cp ${plugin6}/pheasant.mli ${plugin6}/pheasant.ml ${plugin6}/partridge.mli ${plugin6}/partridge.ml plugin6"
****** ocamlopt.byte
module = "plugin1/sheep.mli"
****** ocamlopt.byte
program = "plugin1/sheep.cmxs"
flags = "-I plugin1 -shared"
all_modules = "plugin1/sheep.ml"
****** ocamlopt.byte
module = "plugin2/cow.mli"
****** ocamlopt.byte
program = "plugin2/cow.cmxs"
flags = "-I plugin2 -shared"
all_modules = "plugin2/cow.ml"
****** ocamlopt.byte
module = "plugin2b/cow.mli"
****** ocamlopt.byte
program = "plugin2b/cow.cmxs"
flags = "-I plugin2b -shared"
all_modules = "plugin2b/cow.ml"
****** ocamlopt.byte
module = "plugin2c/cow.mli"
****** ocamlopt.byte
program = "plugin2c/cow.cmxs"
flags = "-I plugin2c -shared"
all_modules = "plugin2c/cow.ml"
****** ocamlopt.byte
module = "plugin3/pig.mli"
****** ocamlopt.byte
program = "plugin3/pig.cmxs"
flags = "-I plugin3 -shared"
all_modules = "plugin3/pig.ml"
****** ocamlopt.byte
module = "plugin4/chicken.mli"
****** ocamlopt.byte
program = "plugin4/chicken.cmxs"
flags = "-I plugin4 -shared"
all_modules = "plugin4/chicken.ml"
****** ocamlopt.byte
module = "plugin5/chicken.mli"
****** ocamlopt.byte
program = "plugin5/chicken.cmxs"
flags = "-I plugin5 -shared"
all_modules = "plugin5/chicken.ml"
****** ocamlopt.byte
module = "plugin6/pheasant.mli"
****** ocamlopt.byte
program = "plugin6/pheasant.cmxs"
flags = "-I plugin6 -shared"
all_modules = "plugin6/pheasant.ml"
****** ocamlopt.byte
module = "plugin6/partridge.mli"
****** ocamlopt.byte
program = "plugin6/partridge.cmxs"
flags = "-I plugin6 -shared"
all_modules = "plugin6/partridge.ml"
****** ocamlopt.byte
program = "${test_build_directory}/test.exe"
libraries = "dynlink"
all_modules = "sheep.cmx test.cmx"
******* run
*)
let () = Sheep.baa Sheep.s (* Use Sheep module *)
let _ = fun (x : Pig.t) -> x (* Reference Pig module *)
(* Test that a privately loaded module cannot have the same name as a
module in the program. *)
let test_sheep () =
match
if Dynlink.is_native then
Dynlink.loadfile_private "plugin1/sheep.cmxs"
else
Dynlink.loadfile_private "plugin1/sheep.cmo"
with
| () -> assert false
| exception Dynlink.Error (
Dynlink.Module_already_loaded "Sheep") -> ()
(* Test repeated loading of a privately-loaded module. *)
let test_cow_repeated () =
if Dynlink.is_native then
Dynlink.loadfile_private "plugin2/cow.cmxs"
else
Dynlink.loadfile_private "plugin2/cow.cmo"
(* Test that a privately loaded module can have the same name as a
previous privately loaded module, in the case where the interfaces are
the same, but the implementations differ. *)
let test_cow_same_name_same_mli () =
if Dynlink.is_native then
Dynlink.loadfile_private "plugin2b/cow.cmxs"
else
Dynlink.loadfile_private "plugin2b/cow.cmo"
(* Test that a privately loaded module can have the same name as a
previous privately loaded module, in the case where neither the interfaces
nor the implementations are the same. *)
let test_cow_same_name_different_mli () =
if Dynlink.is_native then
Dynlink.loadfile_private "plugin2c/cow.cmxs"
else
Dynlink.loadfile_private "plugin2c/cow.cmo"
(* Test that a privately loaded module cannot have the same name as an
interface depended on by modules the program. *)
let test_pig () =
match
if Dynlink.is_native then
Dynlink.loadfile_private "plugin3/pig.cmxs"
else
Dynlink.loadfile_private "plugin3/pig.cmo"
with
| () -> assert false
| exception Dynlink.Error (
Dynlink.Private_library_cannot_implement_interface "Pig") -> ()
(* Test that a privately loaded module can recursively load a module of
the same name. *)
let test_chicken () =
if Dynlink.is_native then
Dynlink.loadfile_private "plugin4/chicken.cmxs"
else
Dynlink.loadfile_private "plugin4/chicken.cmo"
(* Test that a public load of a module M inside a privately-loaded module,
followed by a public load of M, causes an error. *)
let test_pheasant () =
begin
if Dynlink.is_native then
Dynlink.loadfile_private "plugin6/pheasant.cmxs"
else
Dynlink.loadfile_private "plugin6/pheasant.cmo"
end;
match
if Dynlink.is_native then
Dynlink.loadfile "plugin6/partridge.cmxs"
else
Dynlink.loadfile "plugin6/partridge.cmo"
with
| () -> assert false
| exception Dynlink.Error (
Dynlink.Module_already_loaded "Partridge") -> ()
let () =
test_sheep ();
test_cow_repeated ();
test_cow_repeated ();
test_cow_same_name_same_mli ();
test_cow_same_name_different_mli ();
test_pig ();
test_chicken ();
test_pheasant ()

1
toplevel/opttoploop.ml
View File

@ -509,7 +509,6 @@ let refill_lexbuf buffer len =
let _ =
Sys.interactive := true;
Compdynlink.init ();
Compmisc.init_path true;
Clflags.dlcode := true;
()

4
utils/misc.ml
View File

@ -214,6 +214,10 @@ module Stdlib = struct
include String
module Set = Set.Make(String)
module Map = Map.Make(String)
module Tbl = Hashtbl.Make(struct
include String
let hash = Hashtbl.hash
end)
end
external compare : 'a -> 'a -> int = "%compare"

Some files were not shown because too many files have changed in this diff Show More