flambda-backend: To upstream: refactor otherlibs/dynlink/, removing byte/ and native/

Author: mshinwell

.gitignore

@@ -127,8 +127,6 @@ _build
 /otherlibs/*/.dep
 /otherlibs/dynlink/extract_crc
 /otherlibs/dynlink/dynlink_platform_intf.mli
-/otherlibs/dynlink/byte/dynlink.mli
-/otherlibs/dynlink/native/dynlink.mli
 /otherlibs/dynlink/dynlink_compilerlibs/Makefile
 /otherlibs/dynlink/dynlink_compilerlibs/*.ml
 /otherlibs/dynlink/dynlink_compilerlibs/*.mli

Makefile

@@ -636,7 +636,7 @@ natruntop:
 
 # Native dynlink
 
-otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/native/dynlink.ml
+otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/dynlink.ml
 	$(MAKE) -C otherlibs/dynlink allopt
 
 # The lexer

otherlibs/dynlink/.depend

@@ -1,13 +1,13 @@
-byte/dynlink.cmo : \
+dynlink.cmo : \
     dynlink_types.cmi \
-    byte/dynlink_compilerlibs.cmi \
+    dynlink_compilerlibs.cmi \
     dynlink_common.cmi \
-    byte/dynlink.cmi
+    dynlink.cmi
 dynlink.cmi :
 dynlink_common.cmo : \
     dynlink_types.cmi \
     dynlink_platform_intf.cmi \
-    byte/dynlink_compilerlibs.cmi \
+    dynlink_compilerlibs.cmi \
     dynlink_common.cmi
 dynlink_common.cmi : \
     dynlink_platform_intf.cmi
@@ -20,21 +20,21 @@ dynlink_types.cmo : \
     dynlink_types.cmi
 dynlink_types.cmi :
 extract_crc.cmo : \
-    byte/dynlink_compilerlibs.cmi
+    dynlink_compilerlibs.cmi
 dynlink_common.cmx : \
     dynlink_types.cmx \
     dynlink_platform_intf.cmx \
-    native/dynlink_compilerlibs.cmx \
+    dynlink_compilerlibs.cmx \
     dynlink_common.cmi
 dynlink_platform_intf.cmx : \
     dynlink_types.cmx \
     dynlink_platform_intf.cmi
 dynlink_types.cmx : \
     dynlink_types.cmi
 extract_crc.cmx : \
-    native/dynlink_compilerlibs.cmx
-native/dynlink.cmx : \
+    dynlink_compilerlibs.cmx
+dynlink.cmx : \
     dynlink_types.cmx \
-    native/dynlink_compilerlibs.cmx \
+    dynlink_compilerlibs.cmx \
     dynlink_common.cmx \
-    native/dynlink.cmi
+    dynlink.cmi

otherlibs/dynlink/Makefile

@@ -37,16 +37,13 @@ ifeq "$(FLAMBDA)" "true"
 OPTCOMPFLAGS += -O3
 endif
 
-COMPFLAGS += -I byte
-OPTCOMPFLAGS += -I native
-
 LOCAL_SRC=dynlink_compilerlibs
 
-OBJS=byte/dynlink_compilerlibs.cmo dynlink_types.cmo \
-  dynlink_platform_intf.cmo dynlink_common.cmo byte/dynlink.cmo
+OBJS=dynlink_compilerlibs.cmo dynlink_types.cmo \
+  dynlink_platform_intf.cmo dynlink_common.cmo dynlink.cmo
 
-NATOBJS=native/dynlink_compilerlibs.cmx dynlink_types.cmx \
-  dynlink_platform_intf.cmx dynlink_common.cmx native/dynlink.cmx
+NATOBJS=dynlink_compilerlibs.cmx dynlink_types.cmx \
+  dynlink_platform_intf.cmx dynlink_common.cmx dynlink.cmx
 
 # We need/desire access to compilerlibs for various reasons:
 # - The bytecode dynamic linker is in compilerlibs and has many dependencies
@@ -189,17 +186,14 @@ $(LOCAL_SRC)/%.cmx: $(LOCAL_SRC)/%.ml
 # Rules for building the [Dynlink_compilerlibs] bytecode and native packs
 # from their components.
 
-byte/dynlink_compilerlibs.cmo: $(COMPILERLIBS_CMO)
+dynlink_compilerlibs.cmo: $(COMPILERLIBS_CMO)
 	$(OCAMLC) $(COMPFLAGS) -pack -o $@ $(COMPILERLIBS_CMO)
 
-byte/dynlink_compilerlibs.cmi: byte/dynlink_compilerlibs.cmo
+dynlink_compilerlibs.cmi: dynlink_compilerlibs.cmo
 
-native/dynlink_compilerlibs.cmx: $(COMPILERLIBS_CMX)
+dynlink_compilerlibs.cmx: $(COMPILERLIBS_CMX)
 	$(OCAMLOPT) $(COMPFLAGS) $(OPTCOMPFLAGS) -pack -o $@ $(COMPILERLIBS_CMX)
 
-%/dynlink.cmi: dynlink.cmi dynlink.mli
-	cp $^ $*/
-
 # Rules for building the interface of the [Dynlink_compilerlibs] packs.
 # To avoid falling foul of the problem described below, the .cmo and .cmx
 # files for the dynlink-specific compilerlibs packs generated here---and in
@@ -214,17 +208,10 @@ all: dynlink.cma $(extract_crc)
 allopt: dynlink.cmxa
 
 dynlink.cma: $(OBJS)
-	$(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -I byte -o $@ $^
+	$(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o $@ $^
 
 dynlink.cmxa: $(NATOBJS)
-	$(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -I native \
-	            -o $@ $^
-# As for all other .cmxa files, ensure that the .cmx files are in the same
-# directory. If this were omitted, ocamldoc in particular will fail to build
-# with a -opaque warning. Note that installopt refers to $(NATOBJS) so doesn't
-# require this file to exist, hence its inclusion in the recipe for dynlink.cmxa
-# rather than as a dependency elsewhere.
-	cp native/dynlink.cmx dynlink.cmx
+	$(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o $@ $^
 
 # 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,
@@ -235,7 +222,7 @@ dynlink_platform_intf.mli: dynlink_platform_intf.ml
 
 $(eval $(call PROGRAM_SYNONYM,extract_crc))
 
-$(extract_crc): dynlink.cma byte/dynlink_compilerlibs.cmo extract_crc.cmo
+$(extract_crc): dynlink.cma dynlink_compilerlibs.cmo extract_crc.cmo
 	$(OCAMLC) -o $@ $^
 
 install:
@@ -259,33 +246,28 @@ installopt:
 
 partialclean:
 	rm -f $(extract_crc) *.cm[ioaxt] *.cmti *.cmxa \
-	      byte/*.cm[iot] byte/*.cmti \
-	      native/*.cm[ixt] native/*.cmti native/*.o native/*.obj \
+	      *.cm[iotx] *.cmti *.o *.obj \
 	      $(LOCAL_SRC)/*.cm[ioaxt] $(LOCAL_SRC)/*.cmti \
         $(LOCAL_SRC)/*.o $(LOCAL_SRC)/*.obj
 
 clean: partialclean
 	rm -f extract_crc extract_crc.exe
 	rm -f *.a *.lib *.o *.obj *.so *.dll dynlink_platform_intf.mli \
 	      $(LOCAL_SRC)/*.ml $(LOCAL_SRC)/*.mli $(LOCAL_SRC)/Makefile \
-	      $(LOCAL_SRC)/.depend byte/dynlink.mli native/dynlink.mli
+	      $(LOCAL_SRC)/.depend
 
 .PHONY: beforedepend
 beforedepend: dynlink_platform_intf.mli
 
 .PHONY: depend
 DEPEND_DUMMY_FILES=\
-  native/dynlink_compilerlibs.ml \
-  byte/dynlink_compilerlibs.mli \
-  byte/dynlink.mli \
-  native/dynlink.mli
+  dynlink_compilerlibs.ml \
+  dynlink_compilerlibs.mli
 
 depend: beforedepend
 	touch $(DEPEND_DUMMY_FILES)
 	$(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash \
-	  -I byte -bytecode *.mli *.ml byte/dynlink.ml > .depend
-	$(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash \
-	  -I native -native *.ml native/dynlink.ml >> .depend
+	  -bytecode -native *.mli *.ml dynlink.ml > .depend
 	rm -f $(DEPEND_DUMMY_FILES)
 
 include .depend

otherlibs/dynlink/byte/dynlink.ml renamed to otherlibs/dynlink/dynlink.ml

@@ -183,7 +183,95 @@ module Bytecode = struct
     close_in ic
 end
 
-include DC.Make (Bytecode)
+module B = DC.Make (Bytecode)
+
+type global_map = {
+  name : string;
+  crc_intf : Digest.t option;
+  crc_impl : Digest.t option;
+  syms : string list
+}
+
+module Native = struct
+  type handle
+
+  (* mshinwell: We need something better than caml_sys_exit *)
+  external ndl_open : string -> bool -> handle * Cmxs_format.dynheader
+    = "caml_sys_exit" "caml_natdynlink_open"
+  external ndl_run : handle -> string -> unit
+    = "caml_sys_exit" "caml_natdynlink_run"
+  external ndl_getmap : unit -> global_map list
+    = "caml_sys_exit" "caml_natdynlink_getmap"
+  external ndl_globals_inited : unit -> int
+    = "caml_sys_exit" "caml_natdynlink_globals_inited"
+  external ndl_loadsym : string -> Obj.t
+    = "caml_sys_exit" "caml_natdynlink_loadsym"
+
+  module Unit_header = struct
+    type t = Cmxs_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 ()
+
+  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_shared_startup handle =
+    ndl_run handle "_shared_startup"
+
+  let run handle ~unit_header ~priv:_ =
+    List.iter (fun cu ->
+        try ndl_run handle cu
+        with exn ->
+          Printexc.raise_with_backtrace
+            (DT.Error (Library's_module_initializers_failed exn))
+            (Printexc.get_raw_backtrace ()))
+      (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 <> Config.cmxs_magic_number then begin
+      raise (DT.Error (Not_a_bytecode_file filename))
+    end;
+    handle, header.dynu_units
+
+  let unsafe_get_global_value ~bytecode_or_asm_symbol =
+    match ndl_loadsym bytecode_or_asm_symbol with
+    | exception _ -> None
+    | obj -> Some obj
+
+  let finish _handle = ()
+end
+
+module N = DC.Make (Native)
 
 type linking_error = DT.linking_error =
   | Undefined_global of string
@@ -205,3 +293,52 @@ type error = DT.error =
 
 exception Error = DT.Error
 let error_message = DT.error_message
+
+let is_native =
+  match Sys.backend_type with
+  | Native -> true
+  | Bytecode | Other _ -> false
+
+let loadfile file =
+  if is_native then N.loadfile file
+  else B.loadfile file
+
+let loadfile_private file =
+  if is_native then N.loadfile_private file
+  else B.loadfile_private file
+
+let unsafe_get_global_value ~bytecode_or_asm_symbol =
+  if is_native then N.unsafe_get_global_value ~bytecode_or_asm_symbol
+  else B.unsafe_get_global_value ~bytecode_or_asm_symbol
+
+let adapt_filename file =
+  if is_native then N.adapt_filename file
+  else B.adapt_filename file
+
+let set_allowed_units units =
+  if is_native then N.set_allowed_units units
+  else B.set_allowed_units units
+
+let allow_only units =
+  if is_native then N.allow_only units
+  else B.allow_only units
+
+let prohibit units =
+  if is_native then N.prohibit units
+  else B.prohibit units
+
+let main_program_units units =
+  if is_native then N.main_program_units units
+  else B.main_program_units units
+
+let public_dynamically_loaded_units units =
+  if is_native then N.public_dynamically_loaded_units units
+  else B.public_dynamically_loaded_units units
+
+let all_units () =
+  if is_native then N.all_units ()
+  else B.all_units ()
+
+let allow_unsafe_modules allow =
+  if is_native then N.allow_unsafe_modules allow
+  else B.allow_unsafe_modules allow