Merge pull request #10715 from dra27/ocamlnat-hooks

Allow ocamlnat's assemble+link phase to be substituted/hooked

.depend

@@ -6522,9 +6522,9 @@ toplevel/native/topeval.cmo : \
     typing/typedtree.cmi \
     typing/typecore.cmi \
     lambda/translmod.cmi \
+    toplevel/native/tophooks.cmi \
     toplevel/topcommon.cmi \
     lambda/simplif.cmi \
-    asmcomp/proc.cmi \
     typing/printtyped.cmi \
     typing/printtyp.cmi \
     lambda/printlambda.cmi \
@@ -6536,21 +6536,15 @@ toplevel/native/topeval.cmo : \
     utils/load_path.cmi \
     lambda/lambda.cmi \
     typing/includemod.cmi \
-    middle_end/flambda/import_approx.cmi \
     typing/ident.cmi \
-    middle_end/flambda/flambda_middle_end.cmi \
     typing/env.cmi \
     utils/config.cmi \
     driver/compmisc.cmi \
     middle_end/compilenv.cmi \
-    middle_end/closure/closure_middle_end.cmi \
     utils/clflags.cmi \
-    middle_end/backend_intf.cmi \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmi \
     asmcomp/asmlink.cmi \
-    asmcomp/asmgen.cmi \
-    asmcomp/arch.cmo \
     toplevel/native/topeval.cmi
 toplevel/native/topeval.cmx : \
     utils/warnings.cmx \
@@ -6559,9 +6553,9 @@ toplevel/native/topeval.cmx : \
     typing/typedtree.cmx \
     typing/typecore.cmx \
     lambda/translmod.cmx \
+    toplevel/native/tophooks.cmx \
     toplevel/topcommon.cmx \
     lambda/simplif.cmx \
-    asmcomp/proc.cmx \
     typing/printtyped.cmx \
     typing/printtyp.cmx \
     lambda/printlambda.cmx \
@@ -6573,25 +6567,54 @@ toplevel/native/topeval.cmx : \
     utils/load_path.cmx \
     lambda/lambda.cmx \
     typing/includemod.cmx \
-    middle_end/flambda/import_approx.cmx \
     typing/ident.cmx \
-    middle_end/flambda/flambda_middle_end.cmx \
     typing/env.cmx \
     utils/config.cmx \
     driver/compmisc.cmx \
     middle_end/compilenv.cmx \
-    middle_end/closure/closure_middle_end.cmx \
     utils/clflags.cmx \
-    middle_end/backend_intf.cmi \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmx \
     asmcomp/asmlink.cmx \
-    asmcomp/asmgen.cmx \
-    asmcomp/arch.cmx \
     toplevel/native/topeval.cmi
 toplevel/native/topeval.cmi : \
     toplevel/topcommon.cmi \
     parsing/parsetree.cmi
+toplevel/native/tophooks.cmo : \
+    toplevel/topcommon.cmi \
+    asmcomp/proc.cmi \
+    utils/misc.cmi \
+    lambda/lambda.cmi \
+    middle_end/flambda/import_approx.cmi \
+    middle_end/flambda/flambda_middle_end.cmi \
+    utils/config.cmi \
+    middle_end/compilenv.cmi \
+    middle_end/closure/closure_middle_end.cmi \
+    utils/clflags.cmi \
+    middle_end/backend_intf.cmi \
+    asmcomp/asmlink.cmi \
+    asmcomp/asmgen.cmi \
+    asmcomp/arch.cmo \
+    toplevel/native/tophooks.cmi
+toplevel/native/tophooks.cmx : \
+    toplevel/topcommon.cmx \
+    asmcomp/proc.cmx \
+    utils/misc.cmx \
+    lambda/lambda.cmx \
+    middle_end/flambda/import_approx.cmx \
+    middle_end/flambda/flambda_middle_end.cmx \
+    utils/config.cmx \
+    middle_end/compilenv.cmx \
+    middle_end/closure/closure_middle_end.cmx \
+    utils/clflags.cmx \
+    middle_end/backend_intf.cmi \
+    asmcomp/asmlink.cmx \
+    asmcomp/asmgen.cmx \
+    asmcomp/arch.cmx \
+    toplevel/native/tophooks.cmi
+toplevel/native/tophooks.cmi : \
+    toplevel/topcommon.cmi \
+    lambda/lambda.cmi
 toplevel/native/topmain.cmo : \
     toplevel/toploop.cmi \
     toplevel/native/topeval.cmi \

Changes

@@ -290,6 +290,11 @@ Working version
   assembler used by the backend.
   (David Allsopp, review by Gabriel Scherer)
 
+- #10715: Allow the assembler and loader to be substituted in ocamlnat, for
+  example to be replaced with a binary emitter.
+  (David Allsopp and Nathan Rebours, review by Louis Gesbert,
+  Nicolás Ojeda Bär and Gabriel Scherer)
+
 ### Build system:
 
 - #10717: Simplify the installation of man pages

Makefile

@@ -566,6 +566,7 @@ endif
 	$(INSTALL_DATA) \
 	   utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
 	   toplevel/*.cmx toplevel/native/*.cmx \
+	   toplevel/native/tophooks.cmi \
 	   file_formats/*.cmx \
 	   lambda/*.cmx \
 	   driver/*.cmx asmcomp/*.cmx middle_end/*.cmx \

compilerlibs/Makefile.compilerlibs

@@ -366,13 +366,15 @@ TOPLEVEL_CMI = \
 OPTTOPLEVEL = \
   toplevel/genprintval.cmo \
   toplevel/topcommon.cmo \
+  toplevel/native/tophooks.cmo \
   toplevel/native/topeval.cmo \
   toplevel/native/trace.cmo \
   toplevel/toploop.cmo \
   toplevel/topdirs.cmo \
   toplevel/native/topmain.cmo
 OPTTOPLEVEL_CMI = \
   toplevel/topcommon.cmi \
+  toplevel/native/tophooks.cmi \
   toplevel/native/topeval.cmi \
   toplevel/native/trace.cmi \
   toplevel/toploop.cmi \

toplevel/native/topeval.ml

@@ -16,45 +16,22 @@
 (* The interactive toplevel loop *)
 
 open Format
-open Config
 open Misc
 open Parsetree
 open Types
 open Typedtree
 open Outcometree
 open Topcommon
 
-type res = Ok of Obj.t | Err of string
-type evaluation_outcome = Result of Obj.t | Exception of exn
-
-let _dummy = (Ok (Obj.magic 0), Err "")
-
-external ndl_run_toplevel: string -> string -> res
-  = "caml_natdynlink_run_toplevel"
-
 let implementation_label = "native toplevel"
 
 let global_symbol id =
   let sym = Compilenv.symbol_for_global id in
-  match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym with
+  match Tophooks.lookup sym with
   | None ->
     fatal_error ("Toploop.global_symbol " ^ (Ident.unique_name id))
   | Some obj -> obj
 
-let need_symbol sym =
-  Option.is_none (Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym)
-
-let dll_run dll entry =
-  match (try Result (Obj.magic (ndl_run_toplevel dll entry))
-         with exn -> Exception exn)
-  with
-    | Exception _ as r -> r
-    | Result r ->
-        match Obj.magic r with
-          | Ok x -> Result x
-          | Err s -> fatal_error ("Toploop.dll_run " ^ s)
-
-
 let remembered = ref Ident.empty
 
 let rec remember phrase_name i = function
@@ -109,40 +86,11 @@ include Topcommon.MakeEvalPrinter(EvalBase)
 
 let may_trace = ref false (* Global lock on tracing *)
 
-let phrase_seqid = ref 0
-let phrase_name = ref "TOP"
-
-(* CR-soon trefis for mshinwell: copy/pasted from Optmain. Should it be shared
-   or?
-   mshinwell: It should be shared, but after 4.03. *)
-module Backend = struct
-  (* See backend_intf.mli. *)
-
-  let symbol_for_global' = Compilenv.symbol_for_global'
-  let closure_symbol = Compilenv.closure_symbol
-
-  let really_import_approx = Import_approx.really_import_approx
-  let import_symbol = Import_approx.import_symbol
-
-  let size_int = Arch.size_int
-  let big_endian = Arch.big_endian
-
-  let max_sensible_number_of_arguments =
-    (* The "-1" is to allow for a potential closure environment parameter. *)
-    Proc.max_arguments_for_tailcalls - 1
-end
-let backend = (module Backend : Backend_intf.S)
-
-let load_lambda ppf ~module_ident ~required_globals lam size =
+let load_lambda ppf ~module_ident ~required_globals phrase_name lam size =
   if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
   let slam = Simplif.simplify_lambda lam in
   if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
 
-  let dll =
-    if !Clflags.keep_asm_file then !phrase_name ^ ext_dll
-    else Filename.temp_file ("caml" ^ !phrase_name) ext_dll
-  in
-  let filename = Filename.chop_extension dll in
   let program =
     { Lambda.
       code = slam;
@@ -151,33 +99,7 @@ let load_lambda ppf ~module_ident ~required_globals lam size =
       required_globals;
     }
   in
-  let middle_end =
-    if Config.flambda then Flambda_middle_end.lambda_to_clambda
-    else Closure_middle_end.lambda_to_clambda
-  in
-  Asmgen.compile_implementation ~toplevel:need_symbol
-    ~backend ~prefixname:filename
-    ~middle_end ~ppf_dump:ppf program;
-  Asmlink.call_linker_shared [filename ^ ext_obj] dll;
-  Sys.remove (filename ^ ext_obj);
-
-  let dll =
-    if Filename.is_implicit dll
-    then Filename.concat (Sys.getcwd ()) dll
-    else dll in
-  match
-    Fun.protect
-      ~finally:(fun () ->
-          (try Sys.remove dll with Sys_error _ -> ()))
-            (* note: under windows, cannot remove a loaded dll
-               (should remember the handles, close them in at_exit, and then
-               remove files) *)
-      (fun () -> dll_run dll !phrase_name)
-  with
-  | res -> res
-  | exception x ->
-      record_backtrace ();
-      Exception x
+  Tophooks.load ppf phrase_name program
 
 (* Print the outcome of an evaluation *)
 
@@ -191,13 +113,15 @@ let pr_item =
 
 (* Execute a toplevel phrase *)
 
+let phrase_seqid = ref 0
+
 let execute_phrase print_outcome ppf phr =
   match phr with
   | Ptop_def sstr ->
       let oldenv = !toplevel_env in
       incr phrase_seqid;
-      phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
-      Compilenv.reset ?packname:None !phrase_name;
+      let phrase_name = "TOP" ^ string_of_int !phrase_seqid in
+      Compilenv.reset ?packname:None phrase_name;
       Typecore.reset_delayed_checks ();
       let sstr, rewritten =
         match sstr with
@@ -223,19 +147,21 @@ let execute_phrase print_outcome ppf phr =
         if Config.flambda then
           let { Lambda.module_ident; main_module_block_size = size;
                 required_globals; code = res } =
-            Translmod.transl_implementation_flambda !phrase_name
+            Translmod.transl_implementation_flambda phrase_name
               (str, Tcoerce_none)
           in
           remember module_ident 0 sg';
           module_ident, close_phrase res, required_globals, size
         else
-          let size, res = Translmod.transl_store_phrases !phrase_name str in
-          Ident.create_persistent !phrase_name, res, Ident.Set.empty, size
+          let size, res = Translmod.transl_store_phrases phrase_name str in
+          Ident.create_persistent phrase_name, res, Ident.Set.empty, size
       in
       Warnings.check_fatal ();
       begin try
         toplevel_env := newenv;
-        let res = load_lambda ppf ~required_globals ~module_ident res size in
+        let res =
+          load_lambda ppf ~required_globals ~module_ident phrase_name res size
+        in
         let out_phr =
           match res with
           | Result _ ->