diff --git a/src/dune_engine/action_builder0.ml b/src/dune_engine/action_builder0.ml index 5eab827a481..4f9e768a8d9 100644 --- a/src/dune_engine/action_builder0.ml +++ b/src/dune_engine/action_builder0.ml @@ -174,8 +174,8 @@ let fail x = x.fail () type ('input, 'output) memo = - { lazy_ : ('input, 'output * Dep.Set.t) Memo.t Lazy.t - ; eager : ('input, 'output * Dep.Facts.t) Memo.t Lazy.t + { lazy_ : ('input, 'output * Dep.Set.t) Memo.Table.t Lazy.t + ; eager : ('input, 'output * Dep.Facts.t) Memo.Table.t Lazy.t } let create_memo name ~input ?cutoff ?human_readable_description f = diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index c56b56d4754..468edc263d6 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -289,10 +289,11 @@ and Exported : sig "Undefined_recursive_module" exception. *) val build_file_memo : - (Path.t, Import.Digest.t * Import.Digest.t Path.Build.Map.t option) Memo.t + (Path.t, Digest.t * Digest.t Path.Build.Map.t option) Memo.Table.t [@@warning "-32"] - val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.t [@@warning "-32"] + val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.Table.t + [@@warning "-32"] val dep_on_alias_definition : Rules.Dir_rules.Alias_spec.item -> unit Action_builder.t diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml index 163899b9a52..1a29a72dc85 100644 --- a/src/dune_rules/dir_status.ml +++ b/src/dune_rules/dir_status.ml @@ -65,7 +65,7 @@ let check_no_module_consumer stanzas = module DB = struct type nonrec t = { stanzas_per_dir : Dune_file.Stanzas.t Dir_with_dune.t Path.Build.Map.t - ; fn : (Path.Build.t, t) Memo.t + ; fn : (Path.Build.t, t) Memo.Table.t } let stanzas_in db ~dir = Path.Build.Map.find db.stanzas_per_dir dir diff --git a/src/memo/memo.ml b/src/memo/memo.ml index e263e15fa03..0860866f731 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -1021,18 +1021,18 @@ module State = struct ] end -type ('input, 'output) t = - { spec : ('input, 'output) Spec.t - ; cache : ('input, ('input, 'output) Dep_node.t) Store.t - } +module Table = struct + type ('input, 'output) t = + { spec : ('input, 'output) Spec.t + ; cache : ('input, ('input, 'output) Dep_node.t) Store.t + } +end module Stack_frame = struct - type ('input, 'output) memo = ('input, 'output) t - include Stack_frame_without_state let as_instance_of (type i) (Dep_node_without_state.T t) - ~of_:(memo : (i, _) memo) : i option = + ~of_:(memo : (i, _) Table.t) : i option = match Type_eq.Id.same memo.spec.witness t.spec.witness with | Some Type_eq.T -> Some t.input | None -> None @@ -1079,7 +1079,7 @@ let invalidate_dep_node (dep_node : _ Dep_node.t) = let invalidate_store = Store.iter ~f:invalidate_dep_node let create_with_cache (type i o) name ~cache ~input ~cutoff - ~human_readable_description (f : i -> o Fiber.t) = + ~human_readable_description (f : i -> o Fiber.t) : (i, o) Table.t = let spec = Spec.create ~name:(Some name) ~input ~cutoff ~human_readable_description f in @@ -1097,7 +1097,7 @@ let create_with_store (type i) name let create (type i) name ~input:(module Input : Input with type t = i) ?cutoff ?human_readable_description f = (* This mutable table is safe: the implementation tracks all dependencies. *) - let cache = Store.of_table (Table.create (module Input) 2) in + let cache = Store.of_table (Stdune.Table.create (module Input) 2) in let input = (module Input : Store_intf.Input with type t = i) in create_with_cache name ~cache ~input ~cutoff ~human_readable_description f @@ -1113,7 +1113,7 @@ let make_dep_node ~spec ~input : _ Dep_node.t = | No -> false) } -let dep_node (t : (_, _) t) input = +let dep_node (t : (_, _) Table.t) input = match Store.find t.cache input with | Some dep_node -> dep_node | None -> @@ -1366,7 +1366,7 @@ end = struct | Error cycle_error -> raise (Cycle_error.E cycle_error)) end -let exec (type i o) (t : (i, o) t) i = Exec.exec_dep_node (dep_node t i) +let exec (type i o) (t : (i, o) Table.t) i = Exec.exec_dep_node (dep_node t i) let dump_cached_graph ?(on_not_cached = `Raise) ?(time_nodes = false) cell = let rec collect_graph (Dep_node.T dep_node) graph : Graph.t Fiber.t = @@ -1409,8 +1409,6 @@ let dump_cached_graph ?(on_not_cached = `Raise) ?(time_nodes = false) cell = let get_call_stack = Call_stack.get_call_stack_without_state module Invalidation = struct - type ('i, 'o) memo = ('i, 'o) t - (* This is currently used only for informing the user about the reason for restarting a build. *) module Reason = struct @@ -1532,7 +1530,7 @@ module Invalidation = struct let clear_caches ~reason = Leaf { kind = Clear_caches; reason } - let invalidate_cache ~reason { cache; _ } = + let invalidate_cache ~reason ({ cache; _ } : _ Table.t) = Leaf { kind = Clear_cache cache; reason } let invalidate_node ~reason (dep_node : _ Dep_node.t) = @@ -1751,7 +1749,7 @@ module Perf_counters = struct end module For_tests = struct - let get_deps (type i o) (t : (i, o) t) inp = + let get_deps (type i o) (t : (i, o) Table.t) inp = match Store.find t.cache inp with | None -> None | Some dep_node -> ( diff --git a/src/memo/memo.mli b/src/memo/memo.mli index fff08a28fa5..21880e0e303 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -114,12 +114,13 @@ module Build : sig end end -type ('input, 'output) t +(** A table memoizing results of executing a function. *) +module Table : sig + type ('input, 'output) t +end (** A stack frame within a computation. *) module Stack_frame : sig - type ('input, 'output) memo = ('input, 'output) t - type t val to_dyn : t -> Dyn.t @@ -130,7 +131,7 @@ module Stack_frame : sig (** Checks if the stack frame is a frame of the given memoized function and if so, returns [Some i] where [i] is the argument of the function. *) - val as_instance_of : t -> of_:('input, _) memo -> 'input option + val as_instance_of : t -> of_:('input, _) Table.t -> 'input option val human_readable_description : t -> User_message.Style.t Pp.t option end @@ -174,8 +175,6 @@ exception Non_reproducible of exn memoization runs. These sets can be combined into larger sets to then be passed to [reset]. *) module Invalidation : sig - type ('input, 'output) memo = ('input, 'output) t - type t include Monoid.S with type t := t @@ -211,7 +210,7 @@ module Invalidation : sig val clear_caches : reason:Reason.t -> t (** Invalidate all computations stored in a given [memo] table. *) - val invalidate_cache : reason:Reason.t -> _ memo -> t + val invalidate_cache : reason:Reason.t -> _ Table.t -> t (** A list of human-readable strings explaining the reasons for invalidation. The list is truncated to [max_elements] elements, with [max_elements = 1] @@ -227,7 +226,7 @@ val reset : Invalidation.t -> unit module type Input = sig type t - include Table.Key with type t := t + include Stdune.Table.Key with type t := t end module Store : sig @@ -266,12 +265,10 @@ end If the caller provides the [cutoff] equality check, we will use it to check if the function's output is the same as cached in the previous computation. If it's the same, we will be able to skip recomputing the functions that - depend on it. Note: by default Dune wipes all memoization caches on every - run, so this early cutoff optimisation is not effective. To override default - behaviour, run Dune with the flag [DUNE_WATCHING_MODE_INCREMENTAL=true]. + depend on it. If [human_readable_description] is passed, it will be used when displaying - the memo stack to the user. + the Memo stack to the user. Running the computation may raise [Memo.Cycle_error.E] if a dependency cycle is detected. *) @@ -281,7 +278,7 @@ val create : -> ?cutoff:('o -> 'o -> bool) -> ?human_readable_description:('i -> User_message.Style.t Pp.t) -> ('i -> 'o Build.t) - -> ('i, 'o) t + -> ('i, 'o) Table.t (** Like [create] but accepts a custom [store] for memoization. This is useful when there is a custom data structure indexed by keys of type ['i] that is @@ -293,10 +290,10 @@ val create_with_store : -> ?cutoff:('o -> 'o -> bool) -> ?human_readable_description:('i -> User_message.Style.t Pp.t) -> ('i -> 'o Build.t) - -> ('i, 'o) t + -> ('i, 'o) Table.t (** Execute a memoized function. *) -val exec : ('i, 'o) t -> 'i -> 'o Build.t +val exec : ('i, 'o) Table.t -> 'i -> 'o Build.t (** Print the memoized call stack during execution. This is useful for debugging purposes. *) @@ -314,8 +311,8 @@ val push_stack_frame : -> (unit -> 'a Build.t) -> 'a Build.t +(** A single build run. *) module Run : sig - (** A single build run. *) type t module For_tests : sig @@ -342,7 +339,7 @@ end (** Create a "memoization cell" that focuses on a single input/output pair of a memoized function. *) -val cell : ('i, 'o) t -> 'i -> ('i, 'o) Cell.t +val cell : ('i, 'o) Table.t -> 'i -> ('i, 'o) Cell.t val lazy_cell : ?cutoff:('a -> 'a -> bool) @@ -510,7 +507,7 @@ module For_tests : sig by calling [get_deps] with the name and input used during execution. Returns [None] if the dependencies were not computed yet. *) - val get_deps : ('i, _) t -> 'i -> (string option * Dyn.t) list option + val get_deps : ('i, _) Table.t -> 'i -> (string option * Dyn.t) list option (** Forget all memoized values, forcing them to be recomputed on the next build run. *)