Cleanup natdynlink. Automatic initialization of Dynlink (bytecode and native code). Do not use RTLD_GLOBAL for Dynlink.loadfile_private in native code.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8873 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

9 files changed, 146 insertions, 145 deletions

diff --git a/Makefile.nt b/Makefile.nt
index 99d4b6cdc8..ce1ec743e5 100644
--- a/Makefile.nt
+++ b/Makefile.nt
@@ -233,7 +233,7 @@ installbyt:
 	mkdir -p $(STUBLIBDIR)
 	for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done
 	cd win32caml ; $(MAKE) install
-	./build/partial-install.sh
+#	./build/partial-install.sh
 	cp config/Makefile $(LIBDIR)/Makefile.config
 	cp README $(DISTRIB)/Readme.general.txt
 	cp README.win32 $(DISTRIB)/Readme.windows.txt
@@ -583,17 +583,25 @@ alldepend::
 
 # Camlp4
 
-camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte
-	./build/camlp4-byte-only.sh
-camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native
-	./build/camlp4-native-only.sh
+#camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte
+#	./build/camlp4-byte-only.sh
+#camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native
+#	./build/camlp4-native-only.sh
+
+camlp4out:
+
+camlp4opt:
 
 # Ocamlbuild
 
-ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot
-	./build/ocamlbuild-byte-only.sh
-ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot
-	./build/ocamlbuild-native-only.sh
+ocamlbuild.byte:
+
+ocamlbuild.native:
+
+#ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot
+#	./build/ocamlbuild-byte-only.sh
+#ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot
+#	./build/ocamlbuild-native-only.sh
 ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot
 	./build/ocamlbuildlib-native-only.sh
 
diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c
index c14c4e5f7c..84cfb590c9 100644
--- a/asmrun/natdynlink.c
+++ b/asmrun/natdynlink.c
@@ -11,20 +11,16 @@
 #include <stdio.h>
 #include <string.h>
 
-static void *getsym(void *handle, char *module, char *name, int opt){  	 
-  char *fullname = malloc(strlen(module) + strlen(name) + 5); 	 
-  void *sym; 	 
-  sprintf(fullname, "caml%s%s", module, name); 	 
-  sym = caml_dlsym (handle, fullname); 	 
+static void *getsym(void *handle, char *module, char *name){
+  char *fullname = malloc(strlen(module) + strlen(name) + 5);
+  void *sym;
+  sprintf(fullname, "caml%s%s", module, name);
+  sym = caml_dlsym (handle, fullname);
   /*  printf("%s => %lx\n", fullname, (uintnat) sym); */
-  free(fullname); 	 
-  if (NULL == sym && !opt) { 	 
-    printf("natdynlink: cannot find symbol %s\n", fullname); 	 
-    exit(2); 	 
-  } 	 
-  return sym; 	 
-} 	 
- 
+  free(fullname);
+  return sym;
+}
+
 extern char caml_globals_map[];
 
 CAMLprim value caml_natdynlink_getmap(value unit)
@@ -37,7 +33,7 @@ CAMLprim value caml_natdynlink_globals_inited(value unit)
   return Val_int(caml_globals_inited);
 }
 
-CAMLprim value caml_natdynlink_open(value filename)
+CAMLprim value caml_natdynlink_open(value filename, value global)
 {
   CAMLparam1 (filename);
   CAMLlocal1 (res);
@@ -46,13 +42,13 @@ CAMLprim value caml_natdynlink_open(value filename)
 
   /* TODO: dlclose in case of error... */
 
-  handle = caml_dlopen(String_val(filename), 1);
-  
+  handle = caml_dlopen(String_val(filename), 1, Int_val(global));
+
   if (NULL == handle)
     CAMLreturn(caml_copy_string(caml_dlerror()));
 
   sym = caml_dlsym(handle, "caml_plugin_header");
-  if (NULL == sym) 
+  if (NULL == sym)
     CAMLreturn(caml_copy_string("not an OCaml plugin"));
 
   res = caml_alloc_tuple(2);
@@ -66,7 +62,7 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
   CAMLlocal1 (result);
   void *sym,*sym2;
 
-#define optsym(n) getsym(handle,unit,n,1)
+#define optsym(n) getsym(handle,unit,n)
   char *unit;
   void (*entrypoint)(void);
 
@@ -74,15 +70,15 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
 
   sym = optsym("__frametable");
   if (NULL != sym) caml_register_frametable(sym);
-  
+
   sym = optsym("");
   if (NULL != sym) caml_register_dyn_global(sym);
-  
+
   sym = optsym("__data_begin");
   sym2 = optsym("__data_end");
   if (NULL != sym && NULL != sym2)
     caml_page_table_add(In_static_data, sym, sym2);
-  
+
   sym = optsym("__code_begin");
   sym2 = optsym("__code_end");
   if (NULL != sym && NULL != sym2)
@@ -105,8 +101,8 @@ CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol)
 
   /* TODO: dlclose in case of error... */
 
-  handle = caml_dlopen(String_val(filename), 1);
-  
+  handle = caml_dlopen(String_val(filename), 1, 1);
+
   if (NULL == handle) {
     res = caml_alloc(1,1);
     v = caml_copy_string(caml_dlerror());
diff --git a/byterun/dynlink.c b/byterun/dynlink.c
index a6c362b3f2..e08bdc0b2c 100644
--- a/byterun/dynlink.c
+++ b/byterun/dynlink.c
@@ -123,7 +123,7 @@ static void open_shared_lib(char * name)
   realname = caml_search_dll_in_path(&caml_shared_libs_path, name);
   caml_gc_message(0x100, "Loading shared library %s\n",
                   (uintnat) realname);
-  handle = caml_dlopen(realname, 1);
+  handle = caml_dlopen(realname, 1, 1);
   if (handle == NULL)
     caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name,
                           "Reason: %s\n", caml_dlerror());
@@ -201,7 +201,7 @@ CAMLprim value caml_dynlink_open_lib(value mode, value filename)
 
   caml_gc_message(0x100, "Opening shared library %s\n",
                   (uintnat) String_val(filename));
-  handle = caml_dlopen(String_val(filename), Int_val(mode));
+  handle = caml_dlopen(String_val(filename), Int_val(mode), 1);
   if (handle == NULL) caml_failwith(caml_dlerror());
   result = caml_alloc_small(1, Abstract_tag);
   Handle_val(result) = handle;
diff --git a/byterun/osdeps.h b/byterun/osdeps.h
index 0c0c712380..3646fb4f78 100644
--- a/byterun/osdeps.h
+++ b/byterun/osdeps.h
@@ -41,8 +41,10 @@ extern char * caml_search_dll_in_path(struct ext_table * path, char * name);
    can be called.  If [for_execution] is false, functions from this
    shared library will not be called, but just checked for presence,
    so symbol resolution can be skipped.
+   If [global] is true, symbols from the shared library can be used
+   to resolve for other libraries to be opened later on.
    Return [NULL] on error. */
-extern void * caml_dlopen(char * libname, int for_execution);
+extern void * caml_dlopen(char * libname, int for_execution, int global);
 
 /* Close a shared library handle */
 extern void caml_dlclose(void * handle);
diff --git a/byterun/unix.c b/byterun/unix.c
index 00b27de748..f7e3f6326a 100644
--- a/byterun/unix.c
+++ b/byterun/unix.c
@@ -204,7 +204,7 @@ entry_t *caml_lookup_bundle(const char *name)
   return current;
 }
 
-void * caml_dlopen(char * libname, int for_execution)
+void * caml_dlopen(char * libname, int for_execution, int global)
 {
   NSObjectFileImage image;
   entry_t *bentry = caml_lookup_bundle(libname);
@@ -286,9 +286,9 @@ char * caml_dlerror(void)
 #elif defined(__CYGWIN32__)
 /* Use flexdll */
 
-void * caml_dlopen(char * libname, int for_execution)
+void * caml_dlopen(char * libname, int for_execution, int global)
 {
-  int flags = FLEXDLL_RTLD_GLOBAL;
+  int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0);
   if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC;
   return flexdll_dlopen(libname, flags);
 }
@@ -305,7 +305,7 @@ void * caml_dlsym(void * handle, char * name)
 
 void * caml_globalsym(char * name)
 {
-  return flexdll_dlsym(flexdll_dlopen(NULL,0), name);
+  return flexdll_dlsym(flexdll_dlopen(NULL,0,1), name);
 }
 
 char * caml_dlerror(void)
@@ -323,9 +323,9 @@ char * caml_dlerror(void)
 #define RTLD_NODELETE 0
 #endif
 
-void * caml_dlopen(char * libname, int for_execution)
+void * caml_dlopen(char * libname, int for_execution, int global)
 {
-  return dlopen(libname, RTLD_NOW | RTLD_GLOBAL | RTLD_NODELETE);
+  return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : 0) | RTLD_NODELETE);
   /* Could use RTLD_LAZY if for_execution == 0, but needs testing */
 }
 
@@ -361,7 +361,7 @@ char * caml_dlerror(void)
 #endif
 #else
 
-void * caml_dlopen(char * libname, int for_execution)
+void * caml_dlopen(char * libname, int for_execution, int global)
 {
   return NULL;
 }
diff --git a/byterun/win32.c b/byterun/win32.c
index 7fdd133eaa..fa499f959b 100644
--- a/byterun/win32.c
+++ b/byterun/win32.c
@@ -124,10 +124,10 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name)
   return res;
 }
 
-void * caml_dlopen(char * libname, int for_execution)
+void * caml_dlopen(char * libname, int for_execution, int global)
 {
   void *handle;
-  int flags = FLEXDLL_RTLD_GLOBAL;
+  int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0);
   if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC;
   handle = flexdll_dlopen(libname, flags);
   if ((handle != NULL) && ((caml_verb_gc & 0x100) != 0)) {
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index 423d318849..8d8d9a62d0 100644
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -32,6 +32,7 @@ type error =
   | Corrupted_interface of string
   | File_not_found of string
   | Cannot_open_dll of string
+  | Inconsistent_implementation of string
 
 exception Error of error
 
@@ -94,9 +95,20 @@ let default_available_units () =
 
 (* Initialize the linker tables and everything *)
 
+let inited = ref false
+
 let init () =
-  default_crcs := Symtable.init_toplevel();
-  default_available_units ()
+  if not !inited then begin
+    default_crcs := Symtable.init_toplevel();
+    default_available_units ();
+    inited := true;
+  end
+
+let clear_available_units () = init(); clear_available_units ()
+let allow_only l = init(); allow_only l
+let prohibit l = init(); prohibit l
+let add_available_units l = init(); add_available_units l
+let default_available_units () = init(); default_available_units ()
 
 (* Read the CRC of an interface from its .cmi file *)
 
@@ -184,6 +196,7 @@ let load_compunit ic file_name compunit =
   end
 
 let loadfile file_name =
+  init();
   let ic = open_in_bin file_name in
   try
     let buffer = String.create (String.length Config.cmo_magic_number) in
@@ -211,6 +224,7 @@ let loadfile file_name =
     close_in ic; raise exc
 
 let loadfile_private file_name =
+  init();
   let initial_symtable = Symtable.current_state()
   and initial_crc = !crc_interfaces in
   try
@@ -248,5 +262,8 @@ let error_message = function
       "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
diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
index 445492cd48..caee291710 100644
--- a/otherlibs/dynlink/dynlink.mli
+++ b/otherlibs/dynlink/dynlink.mli
@@ -19,12 +19,6 @@ val is_native: bool
 (** [true] if the program is native,
     [false] if the program is bytecode. *)
 
-(** {6 Initialization} *)
-
-val init : unit -> unit
-(** Initialize the [Dynlink] library.
-    Must be called before any other function in this module. *)
-
 (** {6 Dynamic loading of compiled files} *)
 
 val loadfile : string -> unit
@@ -44,6 +38,10 @@ val loadfile_private : string -> unit
     are hidden (cannot be referenced) from other modules dynamically
     loaded afterwards. *)
 
+val adapt_filename : string -> string
+(** In bytecode, the identity function. In native code, replace the last
+    extension with [.cmxs]. *)
+
 (** {6 Access control} *)
 
 val allow_only: string list -> unit
@@ -75,7 +73,8 @@ val allow_unsafe_modules : bool -> unit
     dynamically linked. A compilation unit is ``unsafe'' if it contains
     declarations of external functions, which can break type safety.
     By default, dynamic linking of unsafe object files is
-    not allowed. *)
+    not allowed. In native code, this function does nothing; object files
+    with external functions are always allowed to be dynamically linked. *)
 
 (** {6 Deprecated, low-level API for access control} *)
 
@@ -105,6 +104,12 @@ val clear_available_units : unit -> unit
 (** Empty the list of compilation units accessible to dynamically-linked
     programs. *)
 
+(** {6 Deprecated, initialization} *)
+
+val init : unit -> unit
+(** @deprecated Initialize the [Dynlink] library. This function is called
+    automatically when needed. *)
+
 (** {6 Error reporting} *)
 
 type linking_error =
@@ -121,6 +126,7 @@ type error =
   | Corrupted_interface of string
   | File_not_found of string
   | Cannot_open_dll of string
+  | Inconsistent_implementation of string
 
 exception Error of error
 (** Errors in dynamic linking are reported by raising the [Error]
diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index f2028a4829..b5dd0f4793 100644
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -17,12 +17,10 @@
 
 type handle
 
-external ndl_open: string -> handle * string = "caml_natdynlink_open"
+external ndl_open: string -> bool -> handle * string = "caml_natdynlink_open"
 external ndl_run: handle -> string -> unit = "caml_natdynlink_run"
-external ndl_getmap : unit -> string = "caml_natdynlink_getmap"
-external ndl_globals_inited : unit -> int = "caml_natdynlink_globals_inited"
-
-(** {6 Error reporting} *)
+external ndl_getmap: unit -> string = "caml_natdynlink_getmap"
+external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
 
 type linking_error =
     Undefined_global of string
@@ -38,6 +36,7 @@ type error =
   | Corrupted_interface of string
   | File_not_found of string
   | Cannot_open_dll of string
+  | Inconsistent_implementation of string
 
 exception Error of error
 
@@ -58,15 +57,15 @@ type dynheader = {
 
 let dyn_magic_number = "Caml2007D001"
 
-let dll_filename fname = 
+let dll_filename fname =
   if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
   else fname
 
-let read_file filename =
+let read_file filename priv =
   let dll = dll_filename filename in
   if not (Sys.file_exists dll) then raise (Error (File_not_found dll));
 
-  let (handle,data) as res = ndl_open dll in
+  let (handle,data) as res = ndl_open dll (not priv) in
   if Obj.tag (Obj.repr res) = Obj.string_tag
   then raise (Error (Cannot_open_dll (Obj.magic res)));
 
@@ -90,20 +89,50 @@ type implem_state =
 type state = {
   ifaces: (string*string) StrMap.t;
   implems: (string*string*implem_state) StrMap.t;
-(*  loaded_symbols: string StrMap.t; *)
 }
 
+let empty_state = {
+  ifaces = StrMap.empty;
+  implems = StrMap.empty;
+}
+
+let global_state = ref empty_state
+
 let allow_extension = ref true
 
+let inited = ref false
+
+let default_available_units () =
+  let map : (string*Digest.t*Digest.t*string list) list =
+    Marshal.from_string (ndl_getmap ()) 0 in
+  let exe = Sys.executable_name in
+  let rank = ref 0 in
+  global_state :=
+    List.fold_left
+      (fun st (name,crc_intf,crc_impl,syms) ->
+        rank := !rank + List.length syms;
+        {
+	 ifaces = StrMap.add name (crc_intf,exe) st.ifaces;
+	 implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems;
+        }
+      )
+      empty_state
+      map;
+  allow_extension := true;
+  inited := true
+
+let init () =
+  if !inited then default_available_units ()
+
 let add_check_ifaces allow_ext filename ui ifaces =
   List.fold_left
     (fun ifaces (name, crc) ->
-       if name = ui.name 
+       if name = ui.name
        then StrMap.add name (crc,filename) ifaces
-       else 
+       else
 	 try
 	   let (old_crc,old_src) = StrMap.find name ifaces in
-	   if old_crc <> crc 
+	   if old_crc <> crc
 	   then raise(Error(Inconsistent_import(name)))
 	   else ifaces
 	 with Not_found ->
@@ -130,54 +159,25 @@ let check_implems filename ui implems =
 	 | _ ->
        try
 	 let (old_crc,old_src,state) = StrMap.find name implems in
-	 if crc <> cmx_not_found_crc && old_crc <> crc 
-	 then raise(Error(Inconsistent_import(name)))
+	 if crc <> cmx_not_found_crc && old_crc <> crc
+	 then raise(Error(Inconsistent_implementation(name)))
 	 else match state with
-	   | Check_inited i -> 
-	       if ndl_globals_inited() < i 
+	   | Check_inited i ->
+	       if ndl_globals_inited() < i
 	       then raise(Error(Unavailable_unit name))
 	   | Loaded -> ()
        with Not_found ->
 	 raise (Error(Unavailable_unit name))
     ) ui.imports_cmx
 
-(* Prevent redefinition of a unit symbol *)
-
-(* TODO: make loaded_symbols a global variable, otherwise could
-   break safety with load_private (or not?) *)
-(*
-let check_symbols filename ui symbols =
-  List.fold_left
-    (fun syms name ->
-       try
-	 let old_src = StrMap.find name symbols in
-	 raise (Error(Reloading_symbol(name,old_src,filename)))
-       with Not_found -> 
-	 StrMap.add name filename syms
-    )
-    symbols
-    ui.defines
-*)
-
-let empty_state = {
-  ifaces = StrMap.empty;
-  implems = StrMap.empty;
-(*  loaded_symbols = StrMap.empty; *)
-}
-
-let global_state = ref empty_state
-
-let loadunits priv filename handle units state =
-(*  let new_symbols = 
-    List.fold_left (fun accu ui -> check_symbols filename ui accu)
-      state.loaded_symbols units in *)
-  let new_ifaces = 
-    List.fold_left 
+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 -> 
+      (fun accu ui ->
 	 check_implems filename ui accu;
 	 StrMap.add ui.name (ui.crc,filename,Loaded) accu)
       state.implems units in
@@ -186,41 +186,20 @@ let loadunits priv filename handle units state =
 
   ndl_run handle "_shared_startup";
   List.iter (ndl_run handle) defines;
-  { implems = new_implems; ifaces = new_ifaces; 
-    (*loaded_symbols = new_symbols*) }
+  { implems = new_implems; ifaces = new_ifaces }
 
-let load priv filename state = 
-  let (filename,handle,units) = read_file filename in
-  loadunits priv filename handle units state
+let load priv filename state =
+  init();
+  let (filename,handle,units) = read_file filename priv in
+  loadunits filename handle units state
 
 let loadfile filename = global_state := load false filename !global_state
 let loadfile_private filename = ignore (load true filename !global_state)
-      
-let add_builtin_map st =
-  let map : (string*Digest.t*Digest.t*string list) list = 
-    Marshal.from_string (ndl_getmap ()) 0 in
-  let exe = Sys.executable_name in
-  let rank = ref 0 in
-  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;
-(*
-	 loaded_symbols =
-	   List.fold_left (fun l s -> StrMap.add s exe l) 
-	     st.loaded_symbols syms
-*)
-       }
-    )
-    st
-    map
-
-
-(* is it ok to restrict only the accessible interfaces? *)
+
 let allow_only names =
+  init();
   let old = !global_state.ifaces in
-  let ifaces = 
+  let ifaces =
     List.fold_left
       (fun ifaces name ->
 	 try StrMap.add name (StrMap.find name old) ifaces
@@ -230,20 +209,14 @@ let allow_only names =
   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 default_available_units () =
-  global_state := add_builtin_map empty_state;
-  allow_extension := true
-
-let init () =
-  default_available_units ()
-
-let digest_interface _ _ = 
+let digest_interface _ _ =
   failwith "Dynlink.digest_interface: not implemented in native code"
-let add_interfaces _ _ = 
+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"
@@ -251,10 +224,6 @@ let clear_available_units _ =
   failwith "Dynlink.clear_available_units: not implemented in native code"
 let allow_unsafe_modules _ =
   ()
-(*  failwith "Dynlink.allow_unsafe_modules: not implemented in native code" *)
-
-
-(* Error report *)
 
 (* Error report *)
 
@@ -262,7 +231,7 @@ let error_message = function
     Not_a_bytecode_file name ->
       name ^ " is not an object file"
   | Inconsistent_import name ->
-      "interface or implementation mismatch on " ^ name
+      "interface mismatch on " ^ name
   | Unavailable_unit name ->
       "no implementation available for " ^ name
   | Unsafe_file ->
@@ -282,5 +251,8 @@ let error_message = function
       "cannot find file " ^ name ^ " in search path"
   | Cannot_open_dll reason ->
       "error loading shared library: " ^ reason
+  | Inconsistent_import name ->
+      "implementation mismatch on " ^ name
 
 let is_native = true
+let adapt_filename f = Filename.chop_extension f ^ ".cmxs"