refactor(engine): optimize sandbox config storage (#8035)

We store a sandbox configuration set for every single action we create. For a large build, this can add up. Our old representation was taking 6 words to represent this. This PR changes it to use only a single word. Moreover, this new set now opaque to the GC, speeds up comparison, hashing, etc. Signed-off-by: Rudi Grinberg <[email protected]>
ocaml · Nov 14, 2023 · 2b97b01 · 2b97b01
1 parent b8a51bf
commit 2b97b01
Show file tree

Hide file tree

Showing 9 changed files with 41 additions and 60 deletions.
diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml
@@ -235,7 +235,7 @@ end = struct
 
   (* The current version of the rule digest scheme. We should increment it when
      making any changes to the scheme, to avoid collisions. *)
-  let rule_digest_version = 19
+  let rule_digest_version = 20
 
   let compute_rule_digest
     (rule : Rule.t)

diff --git a/src/dune_engine/sandbox_config.ml b/src/dune_engine/sandbox_config.ml
@@ -70,5 +70,5 @@ module Partial = struct
 end
 
 let disallow (mode : Sandbox_mode.t) =
-  Sandbox_mode.Dict.of_func (fun mode' -> not (Sandbox_mode.equal mode mode'))
+  Sandbox_mode.Set.of_func (fun mode' -> not (Sandbox_mode.equal mode mode'))
 ;;
diff --git a/src/dune_engine/sandbox_mode.ml b/src/dune_engine/sandbox_mode.ml
@@ -30,6 +30,14 @@ let equal a b =
   | Lt | Gt -> false
 ;;
 
+let to_dyn =
+  Dyn.option (function
+    | Symlink -> Variant ("Symlink", [])
+    | Copy -> Variant ("Copy", [])
+    | Hardlink -> Variant ("Hardlink", [])
+    | Patch_back_source_tree -> Variant ("Patch_back_source_tree", []))
+;;
+
 module Dict = struct
   type key = t
 
@@ -70,51 +78,32 @@ module Dict = struct
 end
 
 module Set = struct
-  type key = t
-  type t = bool Dict.t
+  module T = struct
+    type nonrec t = t
+
+    let to_int = function
+      | None -> 0
+      | Some Copy -> 1
+      | Some Symlink -> 2
+      | Some Hardlink -> 3
+      | Some Patch_back_source_tree -> 4
+    ;;
+
+    let all =
+      [ None; Some Copy; Some Symlink; Some Hardlink; Some Patch_back_source_tree ]
+    ;;
+
+    let to_dyn = to_dyn
+  end
 
-  let compare = Dict.compare Bool.compare
-  let of_func = Dict.of_func
-  let singleton k = of_func (equal k)
+  include Bit_set.Make (T)
 
   (* CR-someday amokhov: [Patch_back_source_tree] is a bit special in that it
      can only appear as a singleton. Perhaps, it should be treated differently
      than other sandboxing modes to make meaningless states
      non-representable. *)
   let patch_back_source_tree_only = singleton (Some Patch_back_source_tree)
-
-  let is_patch_back_source_tree_only t =
-    match compare t patch_back_source_tree_only with
-    | Eq -> true
-    | Lt | Gt -> false
-  ;;
-
-  let equal a b =
-    match compare a b with
-    | Eq -> true
-    | Lt | Gt -> false
-  ;;
-
-  let mem = Dict.get
-
-  let inter (x : t) (y : t) : t =
-    { none = x.none && y.none
-    ; copy = x.copy && y.copy
-    ; symlink = x.symlink && y.symlink
-    ; hardlink = x.hardlink && y.hardlink
-    ; patch_back_source_tree = x.patch_back_source_tree && y.patch_back_source_tree
-    }
-  ;;
-
-  let to_dyn { Dict.none; copy; symlink; hardlink; patch_back_source_tree } =
-    Dyn.Record
-      [ "none", Bool none
-      ; "copy", Bool copy
-      ; "symlink", Bool symlink
-      ; "hardlink", Bool hardlink
-      ; "patch_back_source_tree", Bool patch_back_source_tree
-      ]
-  ;;
+  let is_patch_back_source_tree_only t = t = patch_back_source_tree_only
 end
 
 (* The order of sandboxing modes in this list determines the order in which Dune
@@ -148,11 +137,3 @@ let to_string = function
   | Some Hardlink -> "hardlink"
   | Some Patch_back_source_tree -> "patch_back_source_tree"
 ;;
-
-let to_dyn =
-  Dyn.option (function
-    | Symlink -> Variant ("Symlink", [])
-    | Copy -> Variant ("Copy", [])
-    | Hardlink -> Variant ("Hardlink", [])
-    | Patch_back_source_tree -> Variant ("Patch_back_source_tree", []))
-;;
diff --git a/src/dune_engine/sandbox_mode.mli b/src/dune_engine/sandbox_mode.mli
@@ -53,8 +53,8 @@ module Dict : sig
 end
 
 module Set : sig
-  type key = t
-  type t = bool Dict.t
+  type key := t
+  type t
 
   val singleton : key -> t
 

diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-copy.t b/test/blackbox-tests/test-cases/dune-cache/mode-copy.t
@@ -40,9 +40,9 @@ never built [target1] before.
   $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \
   >   2>&1 | grep '_build/default/source\|_build/default/target'
   Workspace-local cache miss: _build/default/source: never seen this target before
-  Shared cache miss [4c8aba9580c271d7ac111bf2d72a147a] (_build/default/source): not found in cache
+  Shared cache miss [790009feab9e691c98ad47625fd7047a] (_build/default/source): not found in cache
   Workspace-local cache miss: _build/default/target1: never seen this target before
-  Shared cache miss [68e477811b0e612a0cc0bb83c205420a] (_build/default/target1): not found in cache
+  Shared cache miss [3aa5494f9cb89c79b5f41e9c6123a666] (_build/default/target1): not found in cache
 
   $ dune_cmd stat hardlinks _build/default/source
   1

diff --git a/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t b/test/blackbox-tests/test-cases/dune-cache/mode-hardlink.t
@@ -35,9 +35,9 @@ never built [target1] before.
   $ dune build --config-file=config target1 --debug-cache=shared,workspace-local \
   >   2>&1 | grep '_build/default/source\|_build/default/target'
   Workspace-local cache miss: _build/default/source: never seen this target before
-  Shared cache miss [4a1c82562ca4c3348fe36436814a9842] (_build/default/source): not found in cache
+  Shared cache miss [1b443618b766306bf5c4846b19349675] (_build/default/source): not found in cache
   Workspace-local cache miss: _build/default/target1: never seen this target before
-  Shared cache miss [3ffbc9519f4ca5e44997bf8ba62de0bb] (_build/default/target1): not found in cache
+  Shared cache miss [44158ca8448d6bb0366c050c668a168c] (_build/default/target1): not found in cache
 
   $ dune_cmd stat hardlinks _build/default/source
   3

diff --git a/test/blackbox-tests/test-cases/dune-cache/repro-check.t b/test/blackbox-tests/test-cases/dune-cache/repro-check.t
@@ -67,7 +67,7 @@ Set 'cache-check-probability' to 1.0, which should trigger the check
   > EOF
   $ rm -rf _build
   $ dune build --config-file config reproducible non-reproducible
-  Warning: cache store error [761869532e88535d64e09b60102c4416]: ((in_cache
+  Warning: cache store error [016cbdcbd1b45ba2125d3738c441dd87]: ((in_cache
   ((non-reproducible 1c8fc4744d4cef1bd2b8f5e915b36be9))) (computed
   ((non-reproducible 6cfaa7a90747882bcf4ffe7252c1cf89)))) after executing
   (echo 'build non-reproducible';cp dep non-reproducible)
@@ -119,7 +119,7 @@ Test that the environment variable and the command line flag work too
 
   $ rm -rf _build
   $ DUNE_CACHE_CHECK_PROBABILITY=1.0 dune build --cache=enabled reproducible non-reproducible
-  Warning: cache store error [761869532e88535d64e09b60102c4416]: ((in_cache
+  Warning: cache store error [016cbdcbd1b45ba2125d3738c441dd87]: ((in_cache
   ((non-reproducible 1c8fc4744d4cef1bd2b8f5e915b36be9))) (computed
   ((non-reproducible 6cfaa7a90747882bcf4ffe7252c1cf89)))) after executing
   (echo 'build non-reproducible';cp dep non-reproducible)
@@ -131,7 +131,7 @@ Test that the environment variable and the command line flag work too
 
   $ rm -rf _build
   $ dune build --cache=enabled --cache-check-probability=1.0 reproducible non-reproducible
-  Warning: cache store error [761869532e88535d64e09b60102c4416]: ((in_cache
+  Warning: cache store error [016cbdcbd1b45ba2125d3738c441dd87]: ((in_cache
   ((non-reproducible 1c8fc4744d4cef1bd2b8f5e915b36be9))) (computed
   ((non-reproducible 6cfaa7a90747882bcf4ffe7252c1cf89)))) after executing
   (echo 'build non-reproducible';cp dep non-reproducible)

diff --git a/test/blackbox-tests/test-cases/dune-cache/trim.t b/test/blackbox-tests/test-cases/dune-cache/trim.t
@@ -78,8 +78,8 @@ entries uniformly.
 
   $ (cd "$PWD/.xdg-cache/dune/db/meta/v5"; grep -rws . -e 'metadata' | sort ) > out
   $ cat out
-  ./50/50673e014878b6b71ee39f1f32ca4726:((8:metadata)(5:files(8:target_a32:5637dd9730e430c7477f52d46de3909c)))
-  ./8f/8f658cc1fc1f083f42e98bbcd5a6ce2f:((8:metadata)(5:files(8:target_b32:8a53bfae3829b48866079fa7f2d97781)))
+  ./57/572f0d07f15fafa10217f0f78d2d4f39:((8:metadata)(5:files(8:target_a32:5637dd9730e430c7477f52d46de3909c)))
+  ./5a/5a512ee6d64f5d7a29d7863269566506:((8:metadata)(5:files(8:target_b32:8a53bfae3829b48866079fa7f2d97781)))
 
   $ digest="$(awk -F: '/target_b/ { digest=$1 } END { print digest }' < out)"
 

diff --git a/test/blackbox-tests/test-cases/patch-back-source-tree.t b/test/blackbox-tests/test-cases/patch-back-source-tree.t
@@ -201,7 +201,7 @@ produced in the sandbox and copied back:
 This is the internal stamp file:
 
   $ ls _build/.actions/default/blah*
-  _build/.actions/default/blah-e7a0efae1209023d2186a50341cd25fa
+  _build/.actions/default/blah-61c2a19beb7c9447302b9348604599d6
 
 And we check that it isn't copied in the source tree: