pkg: don't recreate Pkg_rules.DB values

src/dune_rules/pkg_rules.ml

@@ -1199,24 +1199,12 @@ module DB = struct
       ; dep_pkg_digest : Pkg_digest.t
       }
 
-    let dep_equal (dep : dep) { dep_pkg; dep_loc; dep_pkg_digest } =
-      Pkg.equal dep.dep_pkg dep_pkg
-      && Loc.equal dep.dep_loc dep_loc
-      && Pkg_digest.equal dep.dep_pkg_digest dep_pkg_digest
-    ;;
-
     type entry =
       { pkg : Pkg.t
       ; deps : dep list
       ; pkg_digest : Pkg_digest.t
       }
 
-    let entry_equal (entry : entry) { pkg; deps; pkg_digest } =
-      Pkg.equal entry.pkg pkg
-      && List.equal dep_equal entry.deps deps
-      && Pkg_digest.equal entry.pkg_digest pkg_digest
-    ;;
-
     let entries_by_name_of_lock_dir
           (lock_dir : Dune_pkg.Lock_dir.t)
           ~platform
@@ -1270,8 +1258,6 @@ module DB = struct
     (* Associate each package's digest with the package and its dependencies. *)
     type t = entry Pkg_digest.Map.t
 
-    let equal = Pkg_digest.Map.equal ~equal:entry_equal
-
     let of_lock_dir lock_dir ~platform ~system_provided =
       entries_by_name_of_lock_dir lock_dir ~platform ~system_provided
       |> Package.Name.Map.values
@@ -1335,22 +1321,19 @@ module DB = struct
     ;;
   end
 
+  module Id = Id.Make ()
+
   type t =
-    { pkg_digest_table : Pkg_table.t
+    { id : Id.t
+    ; pkg_digest_table : Pkg_table.t
     ; system_provided : Package.Name.Set.t
     }
 
-  let equal t ({ pkg_digest_table; system_provided } as t') =
-    phys_equal t t'
-    || (Pkg_table.equal t.pkg_digest_table pkg_digest_table
-        && Package.Name.Set.equal t.system_provided system_provided)
-  ;;
+  let equal x y = Id.equal x.id y.id
 
-  let hash = `Do_not_hash
-  let _ = hash
-  (* Because t is large, hashing is expensive, so much so that hashing the db in Input.t
-     below slowed down the dune call in the test repo described in #12248 from 1s to
-     2s. *)
+  let create ~pkg_digest_table ~system_provided =
+    { id = Id.gen (); pkg_digest_table; system_provided }
+  ;;
 
   let pkg_digest_of_name lock_dir platform pkg_name ~system_provided =
     let entries_by_name =
@@ -1393,7 +1376,7 @@ module DB = struct
                >>| Pkg_table.union
                      (Pkg_table.of_lock_dir lock_dir ~platform ~system_provided)
              in
-             { pkg_digest_table; system_provided })
+             create ~pkg_digest_table ~system_provided)
     in
     fun ctx ~allow_sharing -> Memo.exec of_ctx_memo (ctx, allow_sharing)
   ;;
@@ -1409,30 +1392,32 @@ module DB = struct
 
   (* Returns the db for all dev tools combined with the default context, and
      the digest for the dev tool's package. *)
-  let of_dev_tool dev_tool =
+  let of_dev_tool =
     let system_provided = default_system_provided in
-    let* lock_dir = Lock_dir.of_dev_tool dev_tool
-    and* platform = Lock_dir.Sys_vars.solver_env
-    and* lock_dir_active_for_default_ctx =
-      Lock_dir.lock_dir_active Context_name.default
-    in
-    let+ pkg_digest_table =
-      match lock_dir_active_for_default_ctx with
-      | false -> Memo.Lazy.force Pkg_table.all_existing_dev_tools
-      | true ->
-        let+ pkg_digest_table_all_dev_tools =
-          Memo.Lazy.force Pkg_table.all_existing_dev_tools
-        and+ { pkg_digest_table = pkg_digest_table_default_ctx; system_provided = _ } =
-          of_ctx Context_name.default ~allow_sharing:true
-        in
-        Pkg_table.union pkg_digest_table_default_ctx pkg_digest_table_all_dev_tools
+    let inactive_lockdir =
+      Memo.lazy_ (fun () ->
+        let+ pkg_digest_table = Memo.Lazy.force Pkg_table.all_existing_dev_tools in
+        create ~pkg_digest_table ~system_provided)
     in
-    ( { pkg_digest_table; system_provided }
-    , pkg_digest_of_name
+    let of_dev_tool_memo =
+      Memo.create "pkg-db-dev-tool" ~input:(module Dune_pkg.Dev_tool)
+      @@ fun dev_tool ->
+      let+ lock_dir = Lock_dir.of_dev_tool dev_tool
+      and+ platform = Lock_dir.Sys_vars.solver_env in
+      pkg_digest_of_name
         lock_dir
         platform
         (Pkg_dev_tool.package_name dev_tool)
-        ~system_provided )
+        ~system_provided
+    in
+    fun dev_tool ->
+      let+ db =
+        Lock_dir.lock_dir_active Context_name.default
+        >>= function
+        | false -> Memo.Lazy.force inactive_lockdir
+        | true -> of_ctx Context_name.default ~allow_sharing:true
+      and+ pkg_digest = Memo.exec of_dev_tool_memo dev_tool in
+      db, pkg_digest
   ;;
 end