[3.13] backport #9769 (#9926)

* refactor: rename [Dune_load.conf] to [Dune_load.t] (#9766)

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

* refactor: Make [Dune_load.t] abstract (#9767)

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

* refactor: move [Dune_load.Dune_files.in_dir] (#9768)

It doesn't need to be in the [Dune_files] submodule

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

* fix: performance regression from #8447 (#9769)

Get rid of the slow dune file comparison in #9738

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

---------

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
Co-authored-by: Rudi Grinberg <me@rgrinberg.com>

bin/describe/describe_external_lib_deps.ml

@@ -143,7 +143,8 @@ let libs db (context : Context.t) (build_system : Dune_rules.Main.build_system)
   let { Dune_rules.Main.conf; contexts = _; _ } = build_system in
   let open Memo.O in
   let* dune_files =
-    Dune_rules.Dune_load.Dune_files.eval conf.dune_files ~context:(Context.name context)
+    Dune_rules.Dune_load.dune_files conf
+    |> Dune_rules.Dune_load.Dune_files.eval ~context:(Context.name context)
   in
   Memo.parallel_map dune_files ~f:(fun (dune_file : Dune_rules.Dune_file.t) ->
     Memo.parallel_map dune_file.stanzas ~f:(fun stanza ->

bin/describe/describe_pp.ml

@@ -56,7 +56,7 @@ let get_pped_file super_context file =
          >>| Source_tree.Dir.path
          >>| Path.source
        in
-       let* dune_file = Dune_rules.Dune_load.Dune_files.in_dir (dir |> in_build_dir) in
+       let* dune_file = Dune_rules.Only_packages.stanzas_in_dir (dir |> in_build_dir) in
        let staged_pps =
          Option.bind dune_file ~f:(fun dune_file ->
            dune_file.stanzas

bin/describe/describe_workspace.ml

@@ -527,7 +527,8 @@ module Crawl = struct
     let sctx = Context_name.Map.find_exn scontexts context_name in
     let open Memo.O in
     let* dune_files =
-      Dune_load.Dune_files.eval conf.dune_files ~context:context_name
+      Dune_load.dune_files conf
+      |> Dune_load.Dune_files.eval ~context:context_name
       >>| List.filter ~f:(dune_file_is_in_dirs dirs)
     in
     let* exes, exe_libs =
@@ -550,9 +551,9 @@ module Crawl = struct
     in
     let* project_libs =
       (* the list of libraries declared in the project *)
-      Memo.parallel_map conf.projects ~f:(fun project ->
-        let* scope = Scope.DB.find_by_project context project in
-        Scope.libs scope |> Lib.DB.all)
+      Dune_load.projects conf
+      |> Memo.parallel_map ~f:(fun project ->
+        Scope.DB.find_by_project context project >>| Scope.libs >>= Lib.DB.all)
       >>| Lib.Set.union_all
       >>| Lib.Set.filter ~f:(lib_is_in_dirs dirs)
     in

bin/install_uninstall.ml

@@ -81,9 +81,9 @@ module Workspace = struct
   let get () =
     let open Memo.O in
     Memo.run
-      (let+ conf = Dune_rules.Dune_load.load ()
+      (let+ packages = Dune_rules.Dune_load.load () >>| Dune_rules.Dune_load.packages
        and+ contexts = Context.DB.all () in
-       { packages = conf.packages; contexts })
+       { packages; contexts })
   ;;
 
   let package_install_file t ~findlib_toolchain pkg =

doc/changes/9769.md

@@ -0,0 +1,2 @@
+- Fix performance regression for incremental builds (#9769, fixes #9738,
+  @rgrinberg)

src/dune_rules/dune_load.ml

@@ -215,70 +215,26 @@ module Dune_files = struct
 
   type t = one list
 
-  let interpret =
-    let impl (dir, project, dune_file) =
-      let file = Source_tree.Dune_file.path dune_file in
-      let static = Source_tree.Dune_file.get_static_sexp dune_file in
-      match Source_tree.Dune_file.kind dune_file with
-      | Ocaml_script ->
-        Memo.return
-          (Script
-             { script =
-                 { dir
-                 ; project
-                 ; file =
-                     (* we can't introduce ocaml syntax with [(sudir ..)] *)
-                     Option.value_exn file
-                 }
-             ; from_parent = static
-             })
-      | Plain ->
-        let open Memo.O in
-        let+ stanzas = Dune_file.parse static ~dir ~file ~project in
-        Literal stanzas
-    in
-    let module Input = struct
-      type t = Path.Source.t * Dune_project.t * Source_tree.Dune_file.t
-
-      let equal =
-        Tuple.T3.equal Path.Source.equal Dune_project.equal Source_tree.Dune_file.equal
-      ;;
-
-      let hash = Tuple.T3.hash Path.Source.hash Dune_project.hash Poly.hash
-      let to_dyn = Dyn.opaque
-    end
-    in
-    let memo = Memo.create "Dune_files.interpret" ~input:(module Input) impl in
-    fun ~dir ~project ~(dune_file : Source_tree.Dune_file.t) ->
-      Memo.exec memo (dir, project, dune_file)
-  ;;
-
-  let in_dir dir =
-    let source_dir = Path.Build.drop_build_context_exn dir in
-    Source_tree.find_dir source_dir
-    >>= function
-    | None -> Memo.return None
-    | Some d ->
-      (match Source_tree.Dir.dune_file d with
-       | None -> Memo.return None
-       | Some dune_file ->
-         let project = Source_tree.Dir.project d in
-         interpret ~dir:source_dir ~project ~dune_file
-         >>= (function
-          | Literal dune_file -> Memo.return (Some dune_file)
-          | Script script ->
-            let context =
-              match Install.Context.of_path dir with
-              | Some c -> c
-              | None ->
-                User_error.raise
-                  [ Pp.textf
-                      "no context in directory %s"
-                      (Path.Build.to_string_maybe_quoted dir)
-                  ]
-            in
-            let+ dune_file = Script.eval_one ~context script in
-            Some dune_file))
+  let interpret ~dir project dune_file =
+    let file = Source_tree.Dune_file.path dune_file in
+    let static = Source_tree.Dune_file.get_static_sexp dune_file in
+    match Source_tree.Dune_file.kind dune_file with
+    | Ocaml_script ->
+      Memo.return
+        (Script
+           { script =
+               { dir
+               ; project
+               ; file =
+                   (* we can't introduce ocaml syntax with [(sudir ..)] *)
+                   Option.value_exn file
+               }
+           ; from_parent = static
+           })
+    | Plain ->
+      let open Memo.O in
+      let+ stanzas = Dune_file.parse static ~dir ~file ~project in
+      Literal stanzas
   ;;
 
   let eval dune_files ~context =
@@ -293,13 +249,18 @@ module Dune_files = struct
   ;;
 end
 
-type conf =
+type t =
   { dune_files : Dune_files.t
   ; packages : Package.t Package.Name.Map.t
   ; projects : Dune_project.t list
   ; projects_by_root : Dune_project.t Path.Source.Map.t
   }
 
+let dune_files t = t.dune_files
+let packages t = t.packages
+let projects t = t.projects
+let projects_by_root t = t.projects_by_root
+
 module Projects_and_dune_files =
   Monoid.Product
     (Monoid.Appendable_list (struct
@@ -351,7 +312,7 @@ let load () =
   let+ dune_files =
     Appendable_list.to_list dune_files
     |> Memo.parallel_map ~f:(fun (dir, project, dune_file) ->
-      Dune_files.interpret ~dir ~project ~dune_file)
+      Dune_files.interpret ~dir project dune_file)
   in
   { dune_files
   ; packages

src/dune_rules/dune_load.mli

@@ -10,17 +10,16 @@ module Dune_files : sig
   type t
 
   val eval : t -> context:Context_name.t -> Dune_file.t list Memo.t
-  val in_dir : Path.Build.t -> Dune_file.t option Memo.t
 end
 
-type conf = private
-  { dune_files : Dune_files.t
-  ; packages : Package.t Package.Name.Map.t
-  ; projects : Dune_project.t list
-  ; projects_by_root : Dune_project.t Path.Source.Map.t
-  }
+type t
+
+val dune_files : t -> Dune_files.t
+val packages : t -> Package.t Package.Name.Map.t
+val projects : t -> Dune_project.t list
+val projects_by_root : t -> Dune_project.t Path.Source.Map.t
 
 (** Load all dune files. This function is memoized. *)
-val load : unit -> conf Memo.t
+val load : unit -> t Memo.t
 
 val find_project : dir:Path.Build.t -> Dune_project.t Memo.t

src/dune_rules/env_stanza_db.ml

@@ -130,7 +130,7 @@ module Inherit = struct
         (sprintf "%s-root" name)
         ~input:(module Path.Source)
         (fun dir ->
-          let* { Dune_load.projects_by_root; _ } = Dune_load.load ()
+          let* projects_by_root = Dune_load.load () >>| Dune_load.projects_by_root
           and* envs = Memo.Lazy.force for_context in
           let project = Path.Source.Map.find_exn projects_by_root dir in
           let root = root context project in

src/dune_rules/lib.ml

@@ -858,13 +858,14 @@ end = struct
   let projects_by_package =
     Memo.lazy_ (fun () ->
       let open Memo.O in
-      let+ { projects; _ } = Dune_load.load () in
-      List.concat_map projects ~f:(fun project ->
+      Dune_load.load ()
+      >>| Dune_load.projects
+      >>| List.concat_map ~f:(fun project ->
         Dune_project.packages project
         |> Package.Name.Map.to_list_map ~f:(fun _ (pkg : Package.t) ->
           let name = Package.name pkg in
           name, project))
-      |> Package.Name.Map.of_list_exn)
+      >>| Package.Name.Map.of_list_exn)
   ;;
 
   let instantiate_impl (db, name, info, hidden) =

src/dune_rules/main.ml

@@ -3,7 +3,7 @@ open Import
 let () = Inline_tests.linkme
 
 type build_system =
-  { conf : Dune_load.conf
+  { conf : Dune_load.t
   ; contexts : Context.t list
   ; scontexts : Super_context.t Context_name.Map.t
   }

src/dune_rules/main.mli

@@ -12,7 +12,7 @@ val init
   -> unit
 
 type build_system =
-  { conf : Dune_load.conf
+  { conf : Dune_load.t
   ; contexts : Context.t list
   ; scontexts : Super_context.t Context_name.Map.t
   }

src/dune_rules/odoc.ml

@@ -23,7 +23,7 @@ let find_project_by_key =
     Memo.create "project-by-keys" ~input:(module Input) make_map
   in
   fun key ->
-    let* { projects; _ } = Dune_load.load () in
+    let* projects = Dune_load.load () >>| Dune_load.projects in
     let+ map = Memo.exec memo projects in
     Dune_project.File_key.Map.find_exn map key
 ;;

src/dune_rules/odoc_new.ml

@@ -485,7 +485,7 @@ module Valid = struct
   ;;
 
   let get ctx ~all =
-    let* { projects; _ } = Dune_load.load () in
+    let* projects = Dune_load.load () >>| Dune_load.projects in
     Memo.exec valid_libs_and_packages (ctx, all, projects)
   ;;
 

src/dune_rules/only_packages.ml

@@ -31,7 +31,7 @@ let conf =
     match Clflags.t () with
     | No_restriction -> Memo.return None
     | Restrict { names; command_line_option } ->
-      let* { packages; _ } = Dune_load.load () in
+      let* packages = Dune_load.load () >>| Dune_load.packages in
       Package.Name.Set.iter names ~f:(fun pkg_name ->
         if not (Package.Name.Map.mem packages pkg_name)
         then (
@@ -100,48 +100,59 @@ let filter_out_stanzas_from_hidden_packages ~visible_pkgs =
       | _ -> None))
 ;;
 
+type filtered_stanzas =
+  { all : Dune_file.t list
+  ; map : Dune_file.t Path.Source.Map.t
+  }
+
 let filtered_stanzas =
   let db =
     Per_context.create_by_name ~name:"filtered_stanzas"
     @@ fun context ->
-    let* only_packages = Memo.Lazy.force conf
-    and+ { Dune_load.dune_files; packages = _; projects = _; projects_by_root = _ } =
-      Dune_load.load ()
-    in
-    let+ stanzas = Dune_load.Dune_files.eval ~context dune_files in
-    match only_packages with
-    | None -> stanzas
-    | Some visible_pkgs ->
-      List.map stanzas ~f:(fun (dir_conf : Dune_file.t) ->
-        { dir_conf with
-          stanzas = filter_out_stanzas_from_hidden_packages ~visible_pkgs dir_conf.stanzas
-        })
+    Memo.lazy_ (fun () ->
+      let+ only_packages = Memo.Lazy.force conf
+      and+ stanzas =
+        Dune_load.load () >>| Dune_load.dune_files >>= Dune_load.Dune_files.eval ~context
+      in
+      let all =
+        match only_packages with
+        | None -> stanzas
+        | Some visible_pkgs ->
+          List.map stanzas ~f:(fun (dune_file : Dune_file.t) ->
+            { dune_file with
+              stanzas =
+                filter_out_stanzas_from_hidden_packages ~visible_pkgs dune_file.stanzas
+            })
+      in
+      let map =
+        Path.Source.Map.of_list_map_exn all ~f:(fun (dune_file : Dune_file.t) ->
+          dune_file.dir, dune_file)
+      in
+      { all; map })
+    |> Memo.Lazy.force
   in
   fun ctx -> Staged.unstage db ctx
 ;;
 
 let get () =
-  let* { Dune_load.dune_files = _; packages; projects = _; projects_by_root = _ } =
-    Dune_load.load ()
-  in
+  let* packages = Dune_load.load () >>| Dune_load.packages in
   let+ only_packages = Memo.Lazy.force conf in
   Option.value only_packages ~default:packages
 ;;
 
 let stanzas_in_dir dir =
   if Path.Build.is_root dir
   then Memo.return None
-  else
-    Dune_load.Dune_files.in_dir dir
-    >>= function
+  else (
+    match Install.Context.of_path dir with
     | None -> Memo.return None
-    | Some dune_file ->
-      let+ stanzas =
-        Memo.Lazy.force conf
-        >>| function
-        | None -> dune_file.stanzas
-        | Some visible_pkgs ->
-          filter_out_stanzas_from_hidden_packages ~visible_pkgs dune_file.stanzas
-      in
-      Some { dune_file with stanzas }
+    | Some ctx ->
+      let+ filtered_stanzas = filtered_stanzas ctx in
+      let dir = Path.Build.drop_build_context_exn dir in
+      Path.Source.Map.find filtered_stanzas.map dir)
+;;
+
+let filtered_stanzas ctx =
+  let+ filtered_stanzas = filtered_stanzas ctx in
+  filtered_stanzas.all
 ;;

src/dune_rules/scope.ml

@@ -336,7 +336,7 @@ module DB = struct
       let scopes =
         Memo.Lazy.create
         @@ fun () ->
-        let* { Dune_load.projects_by_root; _ } = Dune_load.load () in
+        let* projects_by_root = Dune_load.load () >>| Dune_load.projects_by_root in
         let* stanzas = Only_packages.filtered_stanzas (Context.name context) in
         create_from_stanzas ~projects_by_root ~context stanzas
       in