refactor: split memo into separate modules

src/memo/changed_or_not.ml

@@ -0,0 +1,18 @@
+open! Import
+
+type 'cycle t =
+  | Unchanged
+  | Changed
+  | Cancelled of { dependency_cycle : 'cycle }
+
+let combine x y =
+  match x, y with
+  | Cancelled _, Cancelled _ ->
+    (* This is the only non-commutative case: we prefer the dependency cycle [x] here. We
+       could combine the two cycles into a set of cycles but it doesn't seems worth it. *)
+    x
+  | Cancelled _, _ -> x
+  | _, Cancelled _ -> y
+  | Changed, _ | _, Changed -> Changed
+  | Unchanged, Unchanged -> Unchanged
+;;

src/memo/changed_or_not.mli

@@ -0,0 +1,20 @@
+open! Import
+
+(** Checking dependencies of a Memo node can lead to one of these outcomes:
+
+    - [Unchanged]: All dependencies of the node are up to date. We can therefore skip
+      recomputing the node and can reuse the value computed in the previous run.
+
+    - [Changed]: One of the dependencies has changed since the previous run and the node
+      should therefore be recomputed.
+
+    - [Cancelled _]: One of the dependencies leads to a dependency cycle. In this case,
+      there is no point in recomputing the current node: it's impossible to bring its
+      dependencies up to date! *)
+type 'cycle t =
+  | Unchanged
+  | Changed
+  | Cancelled of { dependency_cycle : 'cycle }
+
+(** Prefers left dependency cycle errors in [Cancelled] but is otherwise commutative. *)
+val combine : 'cycle t -> 'cycle t -> 'cycle t

src/memo/debug.ml

@@ -0,0 +1,3 @@
+let track_locations_of_lazy_values = ref false
+let check_invariants = ref false
+let verbose_diagnostics = ref false

src/memo/deps.ml

@@ -12,13 +12,6 @@ let create ~deps_rev = Array.of_list deps_rev
 let length = Array.length
 let to_list t = Array.fold_left t ~init:[] ~f:(fun acc x -> x :: acc)
 
-module Changed_or_not = struct
-  type 'cycle t =
-    | Unchanged
-    | Changed
-    | Cancelled of { dependency_cycle : 'cycle }
-end
-
 let changed_or_not t ~f =
   let rec go index =
     if index < 0

src/memo/deps.mli

@@ -10,24 +10,6 @@ val create : deps_rev:'node list -> 'node t
 val length : 'node t -> int
 val to_list : 'node t -> 'node list
 
-(** Checking dependencies of a node can lead to one of these outcomes:
-
-    - [Unchanged]: All dependencies of the node are up to date. We can therefore skip
-      recomputing the node and can reuse the value computed in the previous run.
-
-    - [Changed]: One of the dependencies has changed since the previous run and the node
-      should therefore be recomputed.
-
-    - [Cancelled _]: One of the dependencies leads to a dependency cycle. In this case,
-      there is no point in recomputing the current node: it's impossible to bring its
-      dependencies up to date! *)
-module Changed_or_not : sig
-  type 'cycle t =
-    | Unchanged
-    | Changed
-    | Cancelled of { dependency_cycle : 'cycle }
-end
-
 val changed_or_not
   :  'node t
   -> f:('node -> 'cycle Changed_or_not.t Fiber.t)

src/memo/import.ml

@@ -0,0 +1 @@
+include Stdune

src/memo/memo.ml

@@ -3,13 +3,7 @@ open Fiber.O
 module Graph = Dune_graph.Graph
 module Console = Dune_console
 module Counter = Metrics.Counter
-
-module Debug = struct
-  let track_locations_of_lazy_values = ref false
-  let check_invariants = ref false
-  let verbose_diagnostics = ref false
-end
-
+module Debug = Debug
 include Fiber
 
 let when_ x y =
@@ -20,55 +14,14 @@ let when_ x y =
 
 let of_reproducible_fiber = Fun.id
 
-module Allow_cutoff = struct
-  type 'o t =
-    | No
-    | Yes of ('o -> 'o -> bool)
-end
+module Id = Id.Make ()
 
 module type Input = sig
   type t
 
   include Table.Key with type t := t
 end
 
-module Spec = struct
-  type ('i, 'o) t =
-    { name : string option
-    ; (* If the field [witness] precedes any of the functional values ([input]
-         and [f]), then polymorphic comparison actually works for [Spec.t]s. *)
-      witness : 'i Type_eq.Id.t
-    ; input : (module Store_intf.Input with type t = 'i)
-    ; allow_cutoff : 'o Allow_cutoff.t
-    ; f : 'i -> 'o Fiber.t
-    ; human_readable_description : ('i -> User_message.Style.t Pp.t) option
-    }
-
-  let create ~name ~input ~human_readable_description ~cutoff f =
-    let name =
-      match name with
-      | None when !Debug.track_locations_of_lazy_values ->
-        Option.map (Caller_id.get ~skip:[ __FILE__ ]) ~f:(fun loc ->
-          sprintf "lazy value created at %s" (Loc.to_file_colon_line loc))
-      | _ -> name
-    in
-    let allow_cutoff =
-      match cutoff with
-      | None -> Allow_cutoff.No
-      | Some equal -> Yes equal
-    in
-    { name
-    ; input
-    ; allow_cutoff
-    ; witness = Type_eq.Id.create ()
-    ; f
-    ; human_readable_description
-    }
-  ;;
-end
-
-module Id = Id.Make ()
-
 (* We can get rid of this once we use the memoization system more pervasively
    and all the dependencies are properly specified *)
 module Caches = struct
@@ -493,8 +446,6 @@ module Computation0 = struct
   let create () = { ivar = Fiber.Ivar.create (); dag_node = Lazy_dag_node.create () }
 end
 
-module Changed_or_not = Deps.Changed_or_not
-
 (* For debugging *)
 let _print_dep_node ?prefix (dep_node : _ Dep_node.t) =
   let prefix =

src/memo/spec.ml

@@ -0,0 +1,40 @@
+open Import
+
+module Allow_cutoff = struct
+  type 'o t =
+    | No
+    | Yes of ('o -> 'o -> bool)
+end
+
+type ('i, 'o) t =
+  { name : string option
+  ; (* If the field [witness] precedes any of the functional values ([input]
+         and [f]), then polymorphic comparison actually works for [Spec.t]s. *)
+    witness : 'i Type_eq.Id.t
+  ; input : (module Store_intf.Input with type t = 'i)
+  ; allow_cutoff : 'o Allow_cutoff.t
+  ; f : 'i -> 'o Fiber.t
+  ; human_readable_description : ('i -> User_message.Style.t Pp.t) option
+  }
+
+let create ~name ~input ~human_readable_description ~cutoff f =
+  let name =
+    match name with
+    | None when !Debug.track_locations_of_lazy_values ->
+      Option.map (Caller_id.get ~skip:[ __FILE__ ]) ~f:(fun loc ->
+        sprintf "lazy value created at %s" (Loc.to_file_colon_line loc))
+    | _ -> name
+  in
+  let allow_cutoff =
+    match cutoff with
+    | None -> Allow_cutoff.No
+    | Some equal -> Yes equal
+  in
+  { name
+  ; input
+  ; allow_cutoff
+  ; witness = Type_eq.Id.create ()
+  ; f
+  ; human_readable_description
+  }
+;;

src/memo/spec.mli

@@ -0,0 +1,28 @@
+(** A specification for a memoized function. *)
+
+open! Import
+
+module Allow_cutoff : sig
+  type 'o t =
+    | No
+    | Yes of ('o -> 'o -> bool)
+end
+
+type ('i, 'o) t =
+  { name : string option
+  ; (* If the field [witness] precedes any of the functional values ([input]
+         and [f]), then polymorphic comparison actually works for [Spec.t]s. *)
+    witness : 'i Type_eq.Id.t
+  ; input : (module Store_intf.Input with type t = 'i)
+  ; allow_cutoff : 'o Allow_cutoff.t
+  ; f : 'i -> 'o Fiber.t
+  ; human_readable_description : ('i -> User_message.Style.t Pp.t) option
+  }
+
+val create
+  :  name:string option
+  -> input:(module Store_intf.Input with type t = 'a)
+  -> human_readable_description:('a -> User_message.Style.t Pp.t) option
+  -> cutoff:('b -> 'b -> bool) option
+  -> ('a -> 'b Fiber.t)
+  -> ('a, 'b) t