dune utop: do not do custom linking

bin/ocaml/utop.ml

@@ -21,15 +21,15 @@ let term =
   let dir = Common.prefix_target common dir in
   if not (Path.is_directory (Path.of_string dir))
   then User_error.raise [ Pp.textf "cannot find directory: %s" (String.maybe_quoted dir) ];
-  let sctx, utop_path =
+  let sctx, utop_path, requires =
     Scheduler.go ~common ~config (fun () ->
       let open Fiber.O in
       let* setup = Import.Main.setup () in
       Build_system.run_exn (fun () ->
         let open Memo.O in
         let* setup = setup in
+        let context = Import.Main.find_context_exn setup ~name:ctx_name in
         let utop_target =
-          let context = Import.Main.find_context_exn setup ~name:ctx_name in
           let utop_target = Filename.concat dir Utop.utop_exe in
           Path.build (Path.Build.relative (Context.build_dir context) utop_target)
         in
@@ -39,16 +39,23 @@ let term =
           User_error.raise
             [ Pp.textf "no library is defined in %s" (String.maybe_quoted dir) ]
         | true ->
-          let+ () = Build_system.build_file utop_target in
+          let* () = Build_system.build_file utop_target in
           let sctx = Import.Main.find_scontext_exn setup ~name:ctx_name in
-          sctx, Path.to_string utop_target))
+          let* requires =
+            let dir = Path.Build.relative (Context.build_dir context) dir in
+            Utop.requires_under_dir sctx ~dir
+          in
+          let+ requires = Resolve.read_memo requires in
+          sctx, Path.to_string utop_target, requires))
   in
   Hooks.End_of_build.run ();
-  restore_cwd_and_execve
-    common
-    utop_path
-    (utop_path :: args)
-    (Super_context.context_env sctx)
+  let env =
+    Path.Set.fold
+      ~f:(fun dir env -> Env_path.cons ~var:Ocaml.Env.caml_ld_library_path env ~dir)
+      ~init:(Super_context.context_env sctx)
+      (Dune_rules.Lib_flags.L.toplevel_ld_paths requires)
+  in
+  restore_cwd_and_execve common utop_path (utop_path :: args) env
 ;;
 
 let command = Cmd.v info term

doc/changes/8631.md

@@ -0,0 +1,2 @@
+- `dune utop` no longer links `utop` in "custom" mode, which should make this
+  command considerably faster. (#8631, fixes #6894, @nojb)

otherlibs/stdune/src/env_path.ml

@@ -1,5 +1,8 @@
 let var = "PATH"
-let cons env ~dir = Env.update env ~var ~f:(fun _PATH -> Some (Bin.cons_path dir ~_PATH))
+
+let cons ?(var = var) env ~dir =
+  Env.update env ~var ~f:(fun _PATH -> Some (Bin.cons_path dir ~_PATH))
+;;
 
 (* [cons_multi env ~dirs] adds each path in [dirs] to the start of the PATH
    variable in [env], preserving their order *)

otherlibs/stdune/src/env_path.mli

@@ -5,7 +5,7 @@
 val var : Env.Var.t
 
 (** [cons env ~dir] adds [dir] to the start of the PATH variable in [env] *)
-val cons : Env.t -> dir:Path.t -> Env.t
+val cons : ?var:Env.Var.t -> Env.t -> dir:Path.t -> Env.t
 
 val path : Env.t -> Path.t list
 

src/dune_rules/lib_flags.ml

@@ -180,14 +180,18 @@ module L = struct
     Command.Args.S [ Dyn local; Hidden_deps external_; to_iflags (c_include_paths ts) ]
   ;;
 
-  let toplevel_include_paths ts =
+  let toplevel_ld_paths ts =
     let with_dlls =
       List.filter ts ~f:(fun t ->
         match Lib_info.foreign_dll_files (Lib.info t) with
         | [] -> false
         | _ -> true)
     in
-    Path.Set.union (include_paths ts (Lib_mode.Ocaml Byte)) (c_include_paths with_dlls)
+    c_include_paths with_dlls
+  ;;
+
+  let toplevel_include_paths ts =
+    Path.Set.union (include_paths ts (Lib_mode.Ocaml Byte)) (toplevel_ld_paths ts)
   ;;
 end
 

src/dune_rules/lib_flags.mli

@@ -26,6 +26,7 @@ module L : sig
   val include_paths : ?project:Dune_project.t -> t -> Lib_mode.t -> Path.Set.t
   val include_flags : ?project:Dune_project.t -> t -> Lib_mode.t -> _ Command.Args.t
   val c_include_flags : t -> Super_context.t -> _ Command.Args.t
+  val toplevel_ld_paths : t -> Path.Set.t
   val toplevel_include_paths : t -> Path.Set.t
 end
 

src/dune_rules/toplevel.ml

@@ -129,9 +129,8 @@ let setup_module_rules t =
   Super_context.add_rule sctx ~dir main_ml
 ;;
 
-let setup_rules_and_return_exe_path t =
+let setup_rules_and_return_exe_path t ~linkage =
   let open Memo.O in
-  let linkage = Exe.Linkage.custom (Compilation_context.context t.cctx) in
   let program = Source.program t.source in
   let* (_ : Exe.dep_graphs) =
     Exe.build_and_link
@@ -146,7 +145,9 @@ let setup_rules_and_return_exe_path t =
   Exe.exe_path t.cctx ~program ~linkage
 ;;
 
-let setup_rules t = Memo.map (setup_rules_and_return_exe_path t) ~f:ignore
+let setup_rules t ~linkage =
+  Memo.map (setup_rules_and_return_exe_path t ~linkage) ~f:ignore
+;;
 
 type directives =
   { include_paths : Path.Set.t
@@ -241,7 +242,11 @@ module Stanza = struct
         ~preprocessing
     in
     let resolved = make ~cctx ~source ~preprocess:toplevel.pps expander in
-    let* exe = setup_rules_and_return_exe_path resolved in
+    let* exe =
+      setup_rules_and_return_exe_path
+        resolved
+        ~linkage:(Exe.Linkage.custom (Compilation_context.context cctx))
+    in
     let symlink = Path.Build.relative dir (Path.Build.basename exe) in
     Super_context.add_rule
       sctx

src/dune_rules/toplevel.mli

@@ -11,7 +11,7 @@ end
 
 type t
 
-val setup_rules : t -> unit Memo.t
+val setup_rules : t -> linkage:Exe.Linkage.t -> unit Memo.t
 
 val make
   :  cctx:Compilation_context.t

src/dune_rules/utop.ml

@@ -9,7 +9,7 @@ let utop_exe =
      (byte))], the [.exe] correspond the bytecode linked in custom mode. We do
      that so that it works without hassle when generating a utop for a library
      with C stubs. *)
-  Filename.concat utop_dir_basename (exe_name ^ Mode.exe_ext Mode.Native)
+  Filename.concat utop_dir_basename (exe_name ^ Mode.exe_ext Mode.Byte)
 ;;
 
 let source ~dir =
@@ -137,6 +137,14 @@ let libs_and_ppx_under_dir sctx ~db ~dir =
 
 let libs_under_dir sctx ~db ~dir = libs_and_ppx_under_dir sctx ~db ~dir >>| fst
 
+let requires ~loc ~db ~libs =
+  let open Resolve.Memo.O in
+  (loc, Lib_name.of_string "utop")
+  |> Lib.DB.resolve db
+  >>| (fun utop -> utop :: libs)
+  >>= Lib.closure ~linking:true
+;;
+
 let setup sctx ~dir =
   let open Memo.O in
   let* expander = Super_context.expander sctx ~dir in
@@ -165,13 +173,7 @@ let setup sctx ~dir =
   let obj_dir = Toplevel.Source.obj_dir source in
   let loc = Toplevel.Source.loc source in
   let* modules = Toplevel.Source.modules source preprocessing in
-  let requires =
-    let open Resolve.Memo.O in
-    (loc, Lib_name.of_string "utop")
-    |> Lib.DB.resolve db
-    >>| (fun utop -> utop :: libs)
-    >>= Lib.closure ~linking:true
-  in
+  let requires = requires ~loc ~db ~libs in
   let flags =
     let project = Scope.project scope in
     let dune_version = Dune_project.dune_version project in
@@ -195,5 +197,14 @@ let setup sctx ~dir =
       ~preprocessing
   in
   let toplevel = Toplevel.make ~cctx ~source ~preprocess:pps expander in
-  Toplevel.setup_rules toplevel
+  Toplevel.setup_rules toplevel ~linkage:Exe.Linkage.byte
+;;
+
+let requires_under_dir sctx ~dir =
+  let open Memo.O in
+  let* scope = Scope.DB.find_by_dir dir in
+  let db = Scope.libs scope in
+  let* libs = libs_under_dir sctx ~db ~dir:(Path.build dir) in
+  let loc = Toplevel.Source.loc (source ~dir) in
+  requires ~loc ~db ~libs
 ;;

src/dune_rules/utop.mli

@@ -9,3 +9,8 @@ val utop_exe : Filename.t
 val utop_dir_basename : Filename.t
 val libs_under_dir : Super_context.t -> db:Lib.DB.t -> dir:Path.t -> Lib.t list Memo.t
 val setup : Super_context.t -> dir:Path.Build.t -> unit Memo.t
+
+val requires_under_dir
+  :  Super_context.t
+  -> dir:Path.Build.t
+  -> Lib.t list Resolve.t Memo.t

src/install/dune

@@ -5,6 +5,7 @@
   stdune
   dyn
   opam_file_format
+  ocaml
   dune_util
   dune_findlib
   dune_pkg

src/install/roots.ml

@@ -81,7 +81,7 @@ let ocamlpath = Findlib.Config.ocamlpath_var
 let ocamlfind_ignore_dups_in = Findlib.Config.ocamlfind_ignore_dups_in
 
 let to_env_without_path t =
-  [ "CAML_LD_LIBRARY_PATH", Path.Build.relative t.lib_root "stublibs"
+  [ Ocaml.Env.caml_ld_library_path, Path.Build.relative t.lib_root "stublibs"
   ; ocamlpath, t.lib_root
   ; "OCAMLTOP_INCLUDE_PATH", Path.Build.relative t.lib_root "toplevel"
   ; ocamlfind_ignore_dups_in, t.lib_root

src/ocaml/env.ml

@@ -5,3 +5,5 @@ let with_color env =
     | None -> Some "color=always,_"
     | Some s -> Some ("color=always," ^ s))
 ;;
+
+let caml_ld_library_path = "CAML_LD_LIBRARY_PATH"

src/ocaml/env.mli

@@ -2,3 +2,5 @@ open Stdune
 
 (** Set [OCAMLRUNPARAM] to include colors *)
 val with_color : Env.t -> Env.t
+
+val caml_ld_library_path : Env.Var.t

test/blackbox-tests/test-cases/utop/utop-stubs.t/dune-project

@@ -0,0 +1 @@
+(lang dune 3.0)

test/blackbox-tests/test-cases/utop/utop-stubs.t/forutop/dune

@@ -0,0 +1,5 @@
+(library
+ (name forutop)
+ (foreign_stubs
+  (language c)
+  (names forutop_stubs)))

test/blackbox-tests/test-cases/utop/utop-stubs.t/forutop/forutop.ml

@@ -0,0 +1,2 @@
+external hello_in_utop: unit -> string = "hello_in_utop"
+let run () = print_endline (hello_in_utop ())

test/blackbox-tests/test-cases/utop/utop-stubs.t/forutop/forutop_stubs.c

@@ -0,0 +1,6 @@
+#include <caml/alloc.h>
+
+value hello_in_utop(value v_unit)
+{
+  return caml_copy_string("hello in utop");
+}

test/blackbox-tests/test-cases/utop/utop-stubs.t/init_forutop.ml

@@ -0,0 +1 @@
+Forutop.run ();;

test/blackbox-tests/test-cases/utop/utop-stubs.t/run.t

@@ -0,0 +1,2 @@
+  $ dune utop forutop -- init_forutop.ml
+  hello in utop