├── doc ├── dune ├── index.mdx ├── part5-time.mdx ├── part2-dynamic.mdx └── part6-patterns.mdx ├── memoize ├── dune ├── src │ ├── dune │ ├── incr_memoize.mli │ └── incr_memoize.ml └── README.md ├── test ├── test_skeleton.mli ├── test_for_analyzer.mli ├── incremental_test.ml ├── incremental_test.mli ├── test_exceptional_behavior.mli ├── test_config.mli ├── test_generics.mli ├── test_let_syntax.mli ├── test_non_debug.mli ├── test_incremental.mli ├── import.ml ├── dune ├── test_generics.ml ├── test_config.ml ├── test_non_debug.ml ├── test_let_syntax.ml ├── test_exceptional_behavior.ml ├── test_for_analyzer.ml └── test_skeleton.ml ├── dune-project ├── .ocamlformat ├── src ├── config.mli ├── debug.mlh ├── incremental.mli ├── before_or_after.ml ├── before_or_after.mli ├── for_analyzer.mli ├── config.ml ├── node_to_dot.mli ├── node_id.ml ├── sexp_of.ml ├── stabilization_num.ml ├── alarm.ml ├── alarm.mli ├── dune ├── join.mli ├── snapshot.mli ├── if_then_else.mli ├── reduce_balanced.mli ├── at_intervals.mli ├── node_id.mli ├── freeze.mli ├── at.mli ├── raised_exn.ml ├── raised_exn.mli ├── observer.ml ├── alarm_value.mli ├── array_fold.mli ├── var.mli ├── step_function_node.mli ├── config_intf.ml ├── scope.mli ├── on_update_handler.mli ├── expert1.mli ├── at.ml ├── freeze.ml ├── reduce_balanced.ml ├── dot_user_info.mli ├── at_intervals.ml ├── array_fold.ml ├── observer.mli ├── kind.mli ├── snapshot.ml ├── stabilization_num.mli ├── internal_observer.mli ├── join.ml ├── cutoff.mli ├── expert1.ml ├── scope.ml ├── alarm_value.ml ├── unordered_array_fold.mli ├── expert.mli ├── if_then_else.ml ├── ppx_assert_lib.mli ├── bind.mli ├── var.ml ├── step_function_node.ml ├── recompute_heap.mli ├── node_to_dot.ml ├── cutoff.ml ├── import.ml ├── dot_user_info.ml ├── on_update_handler.ml ├── bind.ml ├── for_analyzer_intf.ml ├── adjust_heights_heap.mli ├── ppx_assert_lib.ml ├── for_analyzer.ml ├── unordered_array_fold.ml ├── node.mli ├── internal_observer.ml ├── recompute_heap.ml ├── expert.ml └── adjust_heights_heap.ml ├── src-debug ├── debug.mlh ├── generate_debug_lib.sh └── dune ├── .gitignore ├── step_function ├── test │ ├── test_step_function.mli │ ├── incremental_step_function_test.ml │ ├── dune │ └── test_step_function.ml └── src │ ├── dune │ ├── incremental_step_function.mli │ └── incremental_step_function.ml ├── skeleton ├── incremental_skeleton.ml ├── render_relation.mli ├── dune ├── render_relation.ml ├── node.ml ├── node.mli ├── skeleton.mli ├── incremental_skeleton.mli └── skeleton.ml ├── test-debug ├── generate_debug_test_lib.sh ├── incremental_debug_test.ml └── dune ├── Makefile ├── incremental.opam ├── README.org ├── LICENSE.md ├── CONTRIBUTING.md └── CHANGES.md /doc/dune: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /memoize/dune: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/test_skeleton.mli: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/test_for_analyzer.mli: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /src/config.mli: -------------------------------------------------------------------------------- 1 | include Config_intf.Config 2 | -------------------------------------------------------------------------------- /src/debug.mlh: -------------------------------------------------------------------------------- 1 | [%%define JSC_DEBUG false] 2 | -------------------------------------------------------------------------------- /src-debug/debug.mlh: -------------------------------------------------------------------------------- 1 | [%%define JSC_DEBUG true] 2 | -------------------------------------------------------------------------------- /test/incremental_test.ml: -------------------------------------------------------------------------------- 1 | (* intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/incremental_test.mli: -------------------------------------------------------------------------------- 1 | (* intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/test_exceptional_behavior.mli: -------------------------------------------------------------------------------- 1 | (** test code *) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /src/incremental.mli: -------------------------------------------------------------------------------- 1 | include Incremental_intf.Incremental 2 | -------------------------------------------------------------------------------- /test/test_config.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_generics.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_let_syntax.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_non_debug.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_incremental.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /src/before_or_after.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Before 3 | | After 4 | [@@deriving sexp_of] 5 | -------------------------------------------------------------------------------- /src/before_or_after.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Before 3 | | After 4 | [@@deriving sexp_of] 5 | -------------------------------------------------------------------------------- /step_function/test/test_step_function.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /step_function/test/incremental_step_function_test.ml: -------------------------------------------------------------------------------- 1 | module Test_step_function = Test_step_function 2 | -------------------------------------------------------------------------------- /test/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Time_ns = Time_ns_unix 3 | include Expect_test_helpers_core 4 | -------------------------------------------------------------------------------- /src/for_analyzer.mli: -------------------------------------------------------------------------------- 1 | include 2 | For_analyzer_intf.S with type packed_node := Node.Packed.t and type _ state := State.t 3 | -------------------------------------------------------------------------------- /skeleton/incremental_skeleton.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Node = Node 3 | module Render_relation = Render_relation 4 | include Skeleton 5 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | include Config_intf 4 | 5 | module Default () = struct 6 | let bind_lhs_change_should_invalidate_rhs = true 7 | end 8 | -------------------------------------------------------------------------------- /memoize/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incr_memoize) 3 | (public_name incremental.memoize) 4 | (libraries core incremental janestreet_lru_cache) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /step_function/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental_step_function) 3 | (public_name incremental.incremental_step_function) 4 | (libraries core) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /src/node_to_dot.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | val save_dot : emit_bind_edges:bool -> Format.formatter -> Node.Packed.t list -> unit 4 | val save_dot_to_file : emit_bind_edges:bool -> string -> Node.Packed.t list -> unit 5 | -------------------------------------------------------------------------------- /skeleton/render_relation.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = 4 | | All 5 | | Ancestors 6 | | Descendants 7 | | Both 8 | [@@deriving sexp, enumerate, compare, equal] 9 | 10 | val arg : t Command.Arg_type.t 11 | -------------------------------------------------------------------------------- /src/node_id.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | include Int 4 | 5 | let invariant t = assert (t >= 1) 6 | 7 | let next = 8 | let r = Core.Atomic.make 0 in 9 | fun () -> Core.Atomic.fetch_and_add r 1 + 1 10 | ;; 11 | -------------------------------------------------------------------------------- /step_function/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental_step_function_test) 3 | (libraries core expect_test_helpers_core.expect_test_helpers_base 4 | incremental_step_function) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /skeleton/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental_skeleton) 3 | (public_name incremental.skeleton) 4 | (libraries core incremental core_kernel.reversed_list 5 | textutils_kernel.text_block) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /src/sexp_of.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t [@@deriving sexp_of] 3 | end 4 | 5 | module type S1 = sig 6 | type 'a t [@@deriving sexp_of] 7 | end 8 | 9 | module type S2 = sig 10 | type ('a, 'b) t [@@deriving sexp_of] 11 | end 12 | -------------------------------------------------------------------------------- /test-debug/generate_debug_test_lib.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e -u -o pipefail 4 | 5 | cp --no-preserve mode ../test/*.ml{,i} . 6 | rm test_non_debug.ml{,i} 7 | echo 'module Incremental = Incremental_debug' >>import.ml 8 | chmod a-w *.ml{,i} 9 | -------------------------------------------------------------------------------- /src/stabilization_num.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | include Int 4 | 5 | let invariant t = assert (t >= -1) 6 | let none = -1 7 | let is_none t = t = none 8 | let is_some t = t >= 0 9 | let add1 t = t + 1 10 | 11 | module For_analyzer = Int 12 | -------------------------------------------------------------------------------- /skeleton/render_relation.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = 4 | | All 5 | | Ancestors 6 | | Descendants 7 | | Both 8 | [@@deriving sexp, enumerate, compare, equal] 9 | 10 | let arg = Command.Arg_type.create (fun s -> s |> Sexp.Atom |> t_of_sexp) 11 | -------------------------------------------------------------------------------- /src/alarm.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module Alarm = Timing_wheel.Alarm 4 | 5 | type t = (Types.Alarm_value.t[@sexp.opaque]) Alarm.t [@@deriving sexp_of] 6 | 7 | let invariant (_ : t) = () 8 | let null = Alarm.null () 9 | let get_null () = Alarm.null () 10 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /src/alarm.mli: -------------------------------------------------------------------------------- 1 | (** A timing-wheel alarm used to implement a time-dependent incremental: [at], 2 | [at_intervals], [snapshot], [step_function]. *) 3 | 4 | open! Core 5 | open! Import 6 | 7 | type t = Types.Alarm.t [@@deriving sexp_of] 8 | 9 | include Invariant.S with type t := t 10 | 11 | val null : t 12 | val get_null : unit -> t 13 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental) 3 | (public_name incremental) 4 | (libraries core_kernel.balanced_reducer core incremental_step_function 5 | core_kernel.thread_safe_queue basement core_kernel.timing_wheel uopt 6 | core_kernel.weak_hashtbl) 7 | (preprocess 8 | (pps ppx_jane ppx_optcomp)) 9 | (preprocessor_deps debug.mlh)) 10 | -------------------------------------------------------------------------------- /src/join.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An ['a Join.t] is a type of DAG node. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | include module type of struct 9 | include Types.Join 10 | end 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | include Sexp_of.S1 with type 'a t := 'a t 14 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental_test) 3 | (libraries core core_unix expect_test_helpers_core.expect_test_helpers_base 4 | expect_test_helpers_core patdiff.expect_test_patdiff expect_test_graphviz 5 | expect_test_sexp_diff incremental incremental_skeleton 6 | core_unix.time_ns_unix core_kernel.timing_wheel) 7 | (preprocess 8 | (pps ppx_jane))) 9 | -------------------------------------------------------------------------------- /src/snapshot.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A [Snapshot.t] is a kind of DAG node. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | include module type of struct 9 | include Types.Snapshot 10 | end 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | include Sexp_of.S1 with type 'a t := 'a t 14 | -------------------------------------------------------------------------------- /src/if_then_else.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An ['a If_then_else.t] is a kind of DAG node. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | include module type of struct 9 | include Types.If_then_else 10 | end 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | include Sexp_of.S1 with type 'a t := 'a t 14 | -------------------------------------------------------------------------------- /src/reduce_balanced.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A [Reduce_balanced.t] is a kind of DAG node. ['a] is the type of value being folded. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | val create 9 | : State.t 10 | -> 'a Node.t array 11 | -> f:('a -> 'b) 12 | -> reduce:('b -> 'b -> 'b) 13 | -> 'b Node.t option 14 | -------------------------------------------------------------------------------- /src/at_intervals.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An [At_intervals.t] is a kind of DAG node that changes at a regular time interval. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | include module type of struct 9 | include Types.At_intervals 10 | end 11 | 12 | include Invariant.S with type t := t 13 | include Sexp_of.S with type t := t 14 | -------------------------------------------------------------------------------- /src/node_id.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | Node ids are consecutive integers assigned to nodes as they are created. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | type t = private int [@@deriving compare, sexp_of] 9 | 10 | include Hashable with type t := t 11 | include Invariant.S with type t := t 12 | 13 | val next : unit -> t 14 | val to_string : t -> string 15 | -------------------------------------------------------------------------------- /test-debug/incremental_debug_test.ml: -------------------------------------------------------------------------------- 1 | module Import = Import 2 | module Incremental_test = Incremental_test 3 | module Test_config = Test_config 4 | module Test_for_analyzer = Test_for_analyzer 5 | module Test_generics = Test_generics 6 | module Test_incremental = Test_incremental 7 | module Test_exceptional_behavior = Test_exceptional_behavior 8 | module Test_let_syntax = Test_let_syntax 9 | module Test_skeleton = Test_skeleton 10 | -------------------------------------------------------------------------------- /src/freeze.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An ['a Freeze.t] is a kind of DAG node that takes on the value of another node and 4 | doesn't change thereafter. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | include module type of struct 10 | include Types.Freeze 11 | end 12 | 13 | include Invariant.S1 with type 'a t := 'a t 14 | include Sexp_of.S1 with type 'a t := 'a t 15 | -------------------------------------------------------------------------------- /src/at.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An [At] is a kind of DAG node whose value is [Before] until the clock reaches a 4 | certain time, at which point its value becomes [After]. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | include module type of struct 10 | include Types.At 11 | end 12 | 13 | include Invariant.S with type t := t 14 | include Sexp_of.S with type t := t 15 | -------------------------------------------------------------------------------- /src/raised_exn.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | 4 | type t = 5 | { exn : exn 6 | ; backtrace : Backtrace.t 7 | } 8 | [@@deriving sexp_of] 9 | 10 | let create exn = { exn; backtrace = Backtrace.Exn.most_recent () } 11 | 12 | let reraise_with_message { exn; backtrace } msg = 13 | Exn.raise_with_original_backtrace (Exn.Reraised (msg, exn)) backtrace 14 | ;; 15 | 16 | let reraise { exn; backtrace } = Exn.raise_with_original_backtrace exn backtrace 17 | -------------------------------------------------------------------------------- /src/raised_exn.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A [Raised_exn.t] is an exception paired with the backtrace that was grabbed at the 4 | time the exception was raised. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | type t [@@deriving sexp_of] 10 | 11 | (** [create exn] makes a [t] using [exn] and [Backtrace.Exn.most_recent]. *) 12 | val create : exn -> t 13 | 14 | val reraise : t -> 'a 15 | val reraise_with_message : t -> string -> 'a 16 | -------------------------------------------------------------------------------- /skeleton/node.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Incremental.For_analyzer 3 | 4 | type t = 5 | { id : Node_id.t 6 | ; kind : Kind.t 7 | ; children : Node_id.t list [@sexp.list] 8 | ; bind_children : Node_id.t list [@sexp.list] 9 | ; user_info : Dot_user_info.t option [@sexp.option] 10 | ; recomputed_at : Stabilization_num.t 11 | ; cutoff : Cutoff.t [@default Cutoff.Phys_equal] [@sexp_drop_default.equal] 12 | ; changed_at : Stabilization_num.t 13 | ; height : int 14 | } 15 | [@@deriving sexp] 16 | -------------------------------------------------------------------------------- /skeleton/node.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Incremental.For_analyzer 3 | 4 | (* Snapshot of a [Incr.Node]'s data/metadata for use in analysis/visualization of the 5 | overall graph *) 6 | 7 | type t = 8 | { id : Node_id.t 9 | ; kind : Kind.t 10 | ; children : Node_id.t list 11 | ; bind_children : Node_id.t list 12 | ; user_info : Dot_user_info.t option 13 | ; recomputed_at : Stabilization_num.t 14 | ; cutoff : Cutoff.t 15 | ; changed_at : Stabilization_num.t 16 | ; height : int 17 | } 18 | [@@deriving sexp] 19 | -------------------------------------------------------------------------------- /src/observer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | 4 | type 'a t = 'a Internal_observer.t ref [@@deriving sexp_of] 5 | 6 | let invariant invariant_a t = Internal_observer.invariant invariant_a !t 7 | let observing t = Internal_observer.observing !t 8 | let use_is_allowed t = Internal_observer.use_is_allowed !t 9 | let value_exn t = Internal_observer.value_exn !t 10 | let incr_state t = Internal_observer.incr_state !t 11 | 12 | let on_update_exn t on_update_handler = 13 | Internal_observer.on_update_exn !t on_update_handler 14 | ;; 15 | -------------------------------------------------------------------------------- /src/alarm_value.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An alarm value is stored in the timing wheel and is used to implement time-based 4 | functions: [at], [at_interval], [snapshot], [step_function]. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | module Action : sig 10 | type t = Types.Alarm_value.Action.t 11 | end 12 | 13 | type t = Types.Alarm_value.t 14 | 15 | include Invariant.S with type t := t 16 | include Sexp_of.S with type t := t 17 | 18 | val create : Action.t -> t 19 | -------------------------------------------------------------------------------- /src/array_fold.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An [Array_fold.t] is a kind of DAG node. It is an immutable value that holds the 4 | children of type ['a] and can [compute] the fold to produce a value of type ['b]. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | include module type of struct 10 | include Types.Array_fold 11 | end 12 | 13 | include Sexp_of.S2 with type ('a, 'b) t := ('a, 'b) t 14 | include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t 15 | 16 | val compute : (_, 'b) t -> 'b 17 | -------------------------------------------------------------------------------- /src/var.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A [Var.t] is a leaf in the incremental DAG. *) 4 | 5 | open! Core 6 | open! Import 7 | 8 | include module type of struct 9 | include Types.Var 10 | end 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | include Sexp_of.S1 with type 'a t := 'a t 14 | 15 | module Packed : sig 16 | type t = Types.Var.Packed.t = T : _ Types.Var.t -> t [@@unboxed] [@@deriving sexp_of] 17 | end 18 | 19 | val latest_value : 'a t -> 'a 20 | val incr_state : _ t -> Types.State.t 21 | -------------------------------------------------------------------------------- /src/step_function_node.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An ['a Step_function.t] is a kind of DAG node that represents a function from 4 | [Time_ns.t] to ['a] with a finite number of steps. The steps are in nondecreasing time 5 | order. *) 6 | 7 | open! Core 8 | open! Import 9 | 10 | include module type of struct 11 | include Types.Step_function_node 12 | end 13 | 14 | include Invariant.S1 with type 'a t := 'a t 15 | include Sexp_of.S1 with type 'a t := 'a t 16 | 17 | val advance : _ t -> to_:Time_ns.t -> unit 18 | -------------------------------------------------------------------------------- /src-debug/generate_debug_lib.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e -u -o pipefail 4 | 5 | for f in ../src/*.ml{,i}; do 6 | b=$(basename $f) 7 | cat $f >$b.tmp 8 | case $b in 9 | incremental.*|incremental_intf*) 10 | target=$(echo $b | sed -r 's/incremental/incremental_debug/') 11 | rm -f $target 12 | sed <$b.tmp >$target -r 's/Incremental_intf/Incremental_debug_intf/g' 13 | ;; 14 | *) 15 | target=$b 16 | mv $b.tmp $target 17 | ;; 18 | esac 19 | chmod -w $target 20 | rm -f $b.tmp 21 | done 22 | -------------------------------------------------------------------------------- /src/config_intf.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module type Incremental_config = sig 5 | (** [bind_lhs_change_should_invalidate_rhs = false] is a hack to enable code that worked 6 | with earlier versions of Incremental that did not support invalidation to be more 7 | easily used with this version of Incremental. Except in that situation, one should 8 | leave this as true, and that is what [Default] does. *) 9 | val bind_lhs_change_should_invalidate_rhs : bool 10 | end 11 | 12 | module type Config = sig 13 | module type Incremental_config = Incremental_config 14 | 15 | module Default () : Incremental_config 16 | end 17 | -------------------------------------------------------------------------------- /src/scope.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A scope is a bind in which nodes are created. It is either [top], for nodes not in a 4 | bind, or [Uopt.some packed_bind] for nodes created on the right-hand side of a bind. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | include module type of struct 10 | include Types.Scope 11 | end 12 | 13 | include Invariant.S with type t := t 14 | 15 | val top : t 16 | val get_top : unit -> t 17 | val is_top : t -> bool 18 | val height : t -> int 19 | val is_valid : t -> bool 20 | val is_necessary : t -> bool 21 | val add_node : t -> _ Types.Node.t -> unit 22 | -------------------------------------------------------------------------------- /src/on_update_handler.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An on-update handler is stored in a node or an observer, and is run at the end of a 4 | stabilization either when the value of the node changes, when the handler is 5 | installed, or when the node becomes invalid. *) 6 | 7 | open! Core 8 | open! Import 9 | 10 | module Node_update : sig 11 | type 'a t = 12 | | Necessary of 'a 13 | | Changed of 'a * 'a 14 | | Invalidated 15 | | Unnecessary 16 | [@@deriving compare, sexp_of] 17 | end 18 | 19 | type 'a t [@@deriving sexp_of] 20 | 21 | val create : ('a Node_update.t -> unit) -> at:Stabilization_num.t -> 'a t 22 | val run : 'a t -> 'a Node_update.t -> now:Stabilization_num.t -> unit 23 | -------------------------------------------------------------------------------- /skeleton/skeleton.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Node_id = Incremental.For_analyzer.Node_id 3 | module Dot_user_info = Incremental.For_analyzer.Dot_user_info 4 | 5 | (* Structure for extracting desired information out of an [Incr] graph, to be used for 6 | further analysis/filtering/visualization *) 7 | 8 | type t = 9 | { nodes : Node.t list 10 | ; seen : Node_id.Set.t 11 | ; num_stabilizes : int 12 | } 13 | [@@deriving sexp] 14 | 15 | module Render_target : sig 16 | type t = 17 | | Dot 18 | | Graph_easy 19 | end 20 | 21 | val snapshot : ?normalize:bool -> _ Incremental.State.t -> t 22 | 23 | val to_dot 24 | : ?extra_attrs:(Node.t -> Dot_user_info.t option) 25 | -> ?render_target:Render_target.t 26 | -> ?filtered_nodes:Node.t list 27 | -> ?render_relation:Render_relation.t 28 | -> t 29 | -> string 30 | -------------------------------------------------------------------------------- /src/expert1.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | This module is almost the external interface of the [Expert], but defunctorized, so 4 | it's easier to use from the inside of incremental. *) 5 | 6 | module Dependency : sig 7 | type 'a t [@@deriving sexp_of] 8 | 9 | val create : ?on_change:('a -> unit) -> 'a Node.t -> 'a t 10 | val value : 'a t -> 'a 11 | end 12 | 13 | module Node : sig 14 | type 'a t [@@deriving sexp_of] 15 | 16 | val create 17 | : State.t 18 | -> ?on_observability_change:(is_now_observable:bool -> unit) 19 | -> (unit -> 'a) 20 | -> 'a t 21 | 22 | val watch : 'a t -> 'a Node.t 23 | val make_stale : _ t -> unit 24 | val invalidate : _ t -> unit 25 | val add_dependency : _ t -> _ Dependency.t -> unit 26 | val remove_dependency : _ t -> _ Dependency.t -> unit 27 | end 28 | -------------------------------------------------------------------------------- /src/at.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | type t = Types.At.t = 7 | { main : Before_or_after.t Node.t 8 | ; at : Time_ns.t 9 | ; mutable alarm : Alarm.t 10 | ; clock : (Types.Clock.t[@sexp.opaque]) 11 | } 12 | [@@deriving fields ~iterators:iter, sexp_of] 13 | 14 | let invariant t = 15 | Invariant.invariant t [%sexp_of: t] (fun () -> 16 | let check f = Invariant.check_field t f in 17 | Fields.iter 18 | ~main: 19 | (check (fun (main : Before_or_after.t Node.t) -> 20 | match main.kind with 21 | | Invalid -> () 22 | | Const After -> () (* happens once the current time passes [t.at]. *) 23 | | At t' -> assert (phys_equal t t') 24 | | _ -> assert false)) 25 | ~at:ignore 26 | ~alarm:(check Alarm.invariant) 27 | ~clock:ignore) 28 | ;; 29 | -------------------------------------------------------------------------------- /src/freeze.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | type 'a t = 'a Types.Freeze.t = 7 | { main : 'a Node.t 8 | ; child : 'a Node.t 9 | ; only_freeze_when : 'a -> bool 10 | } 11 | [@@deriving fields ~iterators:iter, sexp_of] 12 | 13 | let invariant _invariant_a t = 14 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 15 | let check f = Invariant.check_field t f in 16 | Fields.iter 17 | ~main: 18 | (check (fun (main : _ Node.t) -> 19 | assert (Scope.is_top main.created_in); 20 | match main.kind with 21 | | Invalid -> () (* happens when freezing an invalid value *) 22 | | Const _ -> () (* happens on becoming frozen *) 23 | | Freeze t' -> assert (phys_equal t t') 24 | | _ -> assert false)) 25 | ~child:ignore 26 | ~only_freeze_when:ignore) 27 | ;; 28 | -------------------------------------------------------------------------------- /src/reduce_balanced.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let create state children ~f ~reduce = 5 | let len = Array.length children in 6 | if len = 0 7 | then None 8 | else ( 9 | let reducer = Balanced_reducer.create_exn () ~len ~reduce in 10 | if debug then Balanced_reducer.invariant (const ()) reducer; 11 | let node = 12 | Expert1.Node.create state (fun () -> 13 | let a = Balanced_reducer.compute_exn reducer in 14 | if debug then Balanced_reducer.invariant (const ()) reducer; 15 | a) 16 | in 17 | for i = 0 to len - 1 do 18 | Expert1.Node.add_dependency 19 | node 20 | (Expert1.Dependency.create children.(i) ~on_change:(fun a -> 21 | Balanced_reducer.set_exn reducer i (f a); 22 | if debug then Balanced_reducer.invariant (const ()) reducer)) 23 | done; 24 | Some (Expert1.Node.watch node)) 25 | ;; 26 | -------------------------------------------------------------------------------- /src/dot_user_info.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A type describing user-controlled metadata optionally attached to nodes, usually for 4 | the purpose of debugging or inspecting the incremental graph. The core of incremental 5 | never uses this. *) 6 | 7 | open Core 8 | open! Import 9 | 10 | type dot = 11 | { label : (string list, String.comparator_witness List.comparator_witness) Set.t 12 | ; attributes : string String.Map.t 13 | } 14 | [@@deriving sexp] 15 | 16 | type t = 17 | | Dot of dot 18 | | Info of Info.t 19 | | Append of 20 | { prior : t 21 | ; new_ : t 22 | } 23 | [@@deriving sexp] 24 | 25 | val info : Info.t -> t 26 | val dot : label:string list -> attributes:string Core.String.Map.t -> t 27 | val to_dot : t -> dot 28 | val append : t -> t -> t 29 | val to_string : ?shape:string -> name:string -> dot -> string 30 | -------------------------------------------------------------------------------- /src/at_intervals.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | type t = Types.At_intervals.t = 7 | { main : unit Node.t 8 | ; base : Time_ns.t 9 | ; interval : Time_ns.Span.t 10 | ; mutable alarm : Alarm.t 11 | ; clock : (Types.Clock.t[@sexp.opaque]) 12 | } 13 | [@@deriving fields ~iterators:iter, sexp_of] 14 | 15 | let invariant t = 16 | Invariant.invariant t [%sexp_of: t] (fun () -> 17 | let check f = Invariant.check_field t f in 18 | Fields.iter 19 | ~main: 20 | (check (fun (main : _ Node.t) -> 21 | match main.kind with 22 | | Invalid -> () 23 | | At_intervals t' -> assert (phys_equal t t') 24 | | _ -> assert false)) 25 | ~base:ignore 26 | ~interval:(check (fun interval -> assert (Time_ns.Span.is_positive interval))) 27 | ~alarm:(check Alarm.invariant) 28 | ~clock:ignore) 29 | ;; 30 | -------------------------------------------------------------------------------- /step_function/src/incremental_step_function.mli: -------------------------------------------------------------------------------- 1 | (** An ['a Step_function.t] is a function from [Time_ns.t] to ['a]. *) 2 | 3 | open! Core 4 | 5 | type 'a t [@@deriving sexp_of] 6 | 7 | include Invariant.S1 with type 'a t := 'a t 8 | 9 | val init : 'a t -> 'a 10 | val steps : 'a t -> (Time_ns.t * 'a) Sequence.t 11 | val value : 'a t -> at:Time_ns.t -> 'a 12 | 13 | (** [constant a] is the step function [t] with [value t ~at = a] for all [at]. *) 14 | val constant : 'a -> 'a t 15 | 16 | (** [create_exn ~init ~steps:[(t_1, v_1); ...; (t_n, vn)]] is the step function [t] with 17 | [value t ~at = init] for [at < t_1], [value t ~at = vi] for [t_i <= at < t_i+1]. 18 | [create_exn] raises if the times aren't in nondecreasing order, i.e. if for some 19 | [i < j], [ti > tj]. *) 20 | val create_exn : init:'a -> steps:(Time_ns.t * 'a) list -> 'a t 21 | 22 | val create_from_sequence : init:'a -> steps:(Time_ns.t * 'a) Sequence.t -> 'a t 23 | -------------------------------------------------------------------------------- /src/array_fold.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | module Node = Types.Node 4 | 5 | type ('a, 'acc) t = ('a, 'acc) Types.Array_fold.t = 6 | { init : 'acc 7 | ; f : 'acc -> 'a -> 'acc 8 | ; children : 'a Node.t array 9 | } 10 | [@@deriving fields ~iterators:iter, sexp_of] 11 | 12 | let invariant invariant_a invariant_acc t = 13 | Invariant.invariant t [%sexp_of: (_, _) t] (fun () -> 14 | let check f = Invariant.check_field t f in 15 | Fields.iter 16 | ~init:(check invariant_acc) 17 | ~f:ignore 18 | ~children: 19 | (check (fun children -> 20 | Array.iter children ~f:(fun (child : _ Node.t) -> 21 | Uopt.invariant invariant_a child.value_opt)))) 22 | ;; 23 | 24 | let compute { init; f; children } = 25 | let result = ref init in 26 | for i = 0 to Array.length children - 1 do 27 | result := f !result (Uopt.value_exn (Array.unsafe_get children i).value_opt) 28 | done; 29 | !result 30 | ;; 31 | -------------------------------------------------------------------------------- /src/observer.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An observer is a "handle" to an {!Internal_observer} that is given to user code -- the 4 | handle exists so the implementation can hold on to the internal observer and use a 5 | finalizer to detect when the user is done with the observer. The finalizer disallows 6 | future use of the observer if it has no on-update handlers, so even if user code uses 7 | a finalizer to resurrect the observer, it will still have [not (use_is_allowed t)]. *) 8 | 9 | open! Core 10 | open! Import 11 | 12 | include module type of struct 13 | include Types.Observer 14 | end 15 | 16 | include Invariant.S1 with type 'a t := 'a t 17 | include Sexp_of.S1 with type 'a t := 'a t 18 | 19 | val observing : 'a t -> 'a Node.t 20 | val use_is_allowed : _ t -> bool 21 | val value_exn : 'a t -> 'a 22 | val on_update_exn : 'a t -> 'a On_update_handler.t -> unit 23 | val incr_state : _ t -> Types.State.t 24 | -------------------------------------------------------------------------------- /src/kind.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | [Kind.t] is a variant type with one constructor for each kind of node (const, var, 4 | map, bind, etc.). *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | include module type of struct 10 | include Types.Kind 11 | end 12 | 13 | include Invariant.S1 with type 'a t := 'a t 14 | include Sexp_of.S1 with type 'a t := 'a t 15 | 16 | val name : _ t -> string 17 | val initial_num_children : _ t -> int 18 | 19 | (** [slow_get_child t ~index] raises unless [0 <= index < max_num_children t]. It will 20 | also raise if the [index]'th child is currently undefined (e.g. a bind node with no 21 | current rhs). *) 22 | val slow_get_child : _ t -> index:int -> Types.Node.Packed.t 23 | 24 | val bind_rhs_child_index : int 25 | val freeze_child_index : int 26 | val if_branch_child_index : int 27 | val join_rhs_child_index : int 28 | val iteri_children : _ t -> f:(int -> Types.Node.Packed.t -> unit) -> unit 29 | -------------------------------------------------------------------------------- /skeleton/incremental_skeleton.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Node = Node 3 | module Render_relation = Render_relation 4 | 5 | type t = 6 | { nodes : Node.t list 7 | ; seen : Incremental.For_analyzer.Node_id.Set.t 8 | ; num_stabilizes : int 9 | } 10 | [@@deriving sexp] 11 | 12 | module Render_target : sig 13 | type t = 14 | | Dot 15 | | Graph_easy 16 | end 17 | 18 | (** Creates a static snapshot of the current incremental graph. 19 | 20 | If [?normalize] is true (default false), node IDs will be normalized relative to the 21 | minimum node ID in the graph. This is primarily useful for tests. *) 22 | val snapshot : ?normalize:bool -> _ Incremental.State.t -> t 23 | 24 | (** Converts a [t] to a dot string that can be rendered by graphviz. *) 25 | val to_dot 26 | : ?extra_attrs:(Node.t -> Incremental.For_analyzer.Dot_user_info.t option) 27 | -> ?render_target:Render_target.t 28 | -> ?filtered_nodes:Node.t list 29 | -> ?render_relation:Render_relation.t 30 | -> t 31 | -> string 32 | -------------------------------------------------------------------------------- /src/snapshot.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | type 'a t = 'a Types.Snapshot.t = 7 | { main : 'a Node.t 8 | ; at : Time_ns.t 9 | ; before : 'a 10 | ; value_at : 'a Node.t 11 | ; clock : (Types.Clock.t[@sexp.opaque]) 12 | } 13 | [@@deriving fields ~iterators:iter, sexp_of] 14 | 15 | let invariant invariant_a t = 16 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 17 | let check f = Invariant.check_field t f in 18 | Fields.iter 19 | ~main: 20 | (check (fun (main : _ Node.t) -> 21 | assert (Scope.is_top main.created_in); 22 | match main.kind with 23 | | Invalid -> () (* happens when snapshotting an invalid node *) 24 | | Const _ -> () (* happens after the snapshot *) 25 | | Snapshot t' -> assert (phys_equal t t') 26 | | _ -> assert false)) 27 | ~at:ignore 28 | ~before:(check invariant_a) 29 | ~value_at:ignore 30 | ~clock:ignore) 31 | ;; 32 | -------------------------------------------------------------------------------- /src/stabilization_num.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A stabilization number is an int that corresponds to one round of stabilization (think 4 | of a round as running from the end of one stabilization to the end of the next 5 | stabilization). Stabilization numbers are used to detect whether a node is stale, i.e. 6 | if one of its children changed at a stabilization since the node was recomputed. *) 7 | 8 | open! Core 9 | open! Import 10 | 11 | type t = private int [@@deriving compare, sexp_of] 12 | 13 | include Equal.S with type t := t 14 | include Invariant.S with type t := t 15 | 16 | (** [none <= t] for all [t]. *) 17 | val none : t 18 | 19 | val zero : t 20 | val is_none : t -> bool 21 | val is_some : t -> bool 22 | val add1 : t -> t 23 | val to_int : t -> int 24 | 25 | module For_analyzer : sig 26 | type nonrec t = t [@@deriving sexp, compare] 27 | 28 | include Comparable.S with type t := t 29 | 30 | val to_string : t -> string 31 | end 32 | -------------------------------------------------------------------------------- /src/internal_observer.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An observer is a root of the incremental DAG -- all descendants of an observer are 4 | "necessary", so that stabilization ensures their values are up to date. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | type 'a t = 'a Types.Internal_observer.t 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | include Sexp_of.S1 with type 'a t := 'a t 13 | 14 | val same : _ t -> _ t -> bool 15 | val observing : 'a t -> 'a Node.t 16 | val use_is_allowed : _ t -> bool 17 | val value_exn : 'a t -> 'a 18 | val on_update_exn : 'a t -> 'a On_update_handler.t -> unit 19 | val unlink : _ t -> unit 20 | val incr_state : _ t -> Types.State.t 21 | 22 | module Packed : sig 23 | type t = Types.Internal_observer.Packed.t = T : _ Types.Internal_observer.t -> t 24 | [@@unboxed] [@@deriving sexp_of] 25 | 26 | include Invariant.S with type t := t 27 | 28 | val next_in_all : t -> t Uopt.t 29 | val set_prev_in_all : t -> t Uopt.t -> unit 30 | end 31 | -------------------------------------------------------------------------------- /src/join.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | type 'a t = 'a Types.Join.t = 7 | { main : 'a Node.t 8 | ; lhs : 'a Node.t Node.t 9 | ; lhs_change : unit Node.t 10 | ; mutable rhs : 'a Node.t Uopt.t 11 | } 12 | [@@deriving fields ~iterators:iter, sexp_of] 13 | 14 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 15 | 16 | let invariant _invariant_a t = 17 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 18 | let check f = Invariant.check_field t f in 19 | Fields.iter 20 | ~main: 21 | (check (fun (main : _ Node.t) -> 22 | match main.kind with 23 | | Invalid -> () 24 | | Join_main t' -> assert (same t t') 25 | | _ -> assert false)) 26 | ~lhs:ignore 27 | ~lhs_change: 28 | (check (fun (lhs_change : _ Node.t) -> 29 | match lhs_change.kind with 30 | | Invalid -> () 31 | | Join_lhs_change t' -> assert (same t t') 32 | | _ -> assert false)) 33 | ~rhs:ignore) 34 | ;; 35 | -------------------------------------------------------------------------------- /incremental.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/incremental" 5 | bug-reports: "https://github.com/janestreet/incremental/issues" 6 | dev-repo: "git+https://github.com/janestreet/incremental.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/incremental/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "basement" 15 | "core" 16 | "core_kernel" 17 | "janestreet_lru_cache" 18 | "ppx_jane" 19 | "ppx_optcomp" 20 | "textutils_kernel" 21 | "uopt" 22 | "dune" {>= "3.17.0"} 23 | ] 24 | available: arch != "arm32" & arch != "x86_32" 25 | synopsis: "Library for incremental computations" 26 | description: " 27 | Part of Jane Street's Core library 28 | The Core suite of libraries is an industrial strength alternative to 29 | OCaml's standard library that was developed by Jane Street, the 30 | largest industrial user of OCaml. 31 | " 32 | -------------------------------------------------------------------------------- /src/cutoff.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An ['a Cutoff.t] is a function that returns [true] if propagation of changes should be 4 | cutoff at a node based on the old value and the (possible) new value of the node. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | type 'a t [@@deriving sexp_of] 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | 13 | val create : (old_value:'a -> new_value:'a -> bool) -> 'a t 14 | val of_compare : ('a -> 'a -> int) -> 'a t 15 | val of_equal : ('a -> 'a -> bool) -> 'a t 16 | val always : _ t 17 | val never : _ t 18 | val get_always : unit -> _ t 19 | val get_never : unit -> _ t 20 | val phys_equal : _ t 21 | val poly_equal : _ t 22 | val equal : 'a t -> 'a t -> bool 23 | val should_cutoff : 'a t -> old_value:'a -> new_value:'a -> bool 24 | 25 | module For_analyzer : sig 26 | type 'a t' := 'a t 27 | 28 | type t = 29 | | Always 30 | | Never 31 | | Phys_equal 32 | | Compare 33 | | Equal 34 | | F 35 | [@@deriving sexp, equal] 36 | 37 | val of_cutoff : _ t' -> t 38 | val to_string : t -> string 39 | end 40 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | Incremental is a library that gives you a way of building complex 2 | computations that can update efficiently in response to their inputs 3 | changing, inspired by the work of [[http://www.umut-acar.org/self-adjusting-computation][Umut Acar et. al.]] on self-adjusting 4 | computations. Incremental can be useful in a number of applications, 5 | including: 6 | 7 | - Building large calculations (of the kind you might build into a 8 | spreadsheet) that can react efficiently to changing data. 9 | - Constructing views in GUI applications that can incorporate new data 10 | efficiently. 11 | - Computing derived data while guaranteeing that the derived data 12 | stays in sync with the source data, for instance filtering or 13 | inversing a mapping. 14 | 15 | You can find detailed documentation of the library and how to use 16 | it in [[https://github.com/janestreet/incremental/blob/master/src/incremental_intf.ml][incremental/src/incremental_intf.ml]]. You can also find an 17 | informal introduction to the library in this [[https://blog.janestreet.com/introducing-incremental][blog post]] 18 | and [this video](https://www.youtube.com/watch?v=G6a5G5i4gQU). 19 | -------------------------------------------------------------------------------- /src/expert1.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module Dependency = struct 5 | type 'a t = 'a Expert.edge [@@deriving sexp_of] 6 | 7 | let create ?(on_change = ignore) child : _ t = { child; on_change; index = Uopt.none } 8 | 9 | let value (t : _ t) = 10 | let state = t.child.state in 11 | if debug 12 | then 13 | State.Expert.assert_currently_running_node_is_parent 14 | state 15 | t.child 16 | "Dependency.value"; 17 | (* Not exposing the _exn, because this function is advertised as being usable only 18 | inside the callbacks of parents, where it will not raise. *) 19 | Node.value_exn t.child 20 | ;; 21 | end 22 | 23 | module Node = struct 24 | type nonrec 'a t = 'a Node.t [@@deriving sexp_of] 25 | 26 | let create state ?(on_observability_change = fun ~is_now_observable:_ -> ()) f = 27 | State.Expert.create state ~on_observability_change f 28 | ;; 29 | 30 | let make_stale = State.Expert.make_stale 31 | let watch = Fn.id 32 | let invalidate = State.Expert.invalidate 33 | let add_dependency = State.Expert.add_dependency 34 | let remove_dependency = State.Expert.remove_dependency 35 | end 36 | -------------------------------------------------------------------------------- /test-debug/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental_debug_test) 3 | (libraries core core_unix expect_test_helpers_core.expect_test_helpers_base 4 | expect_test_helpers_core patdiff.expect_test_patdiff expect_test_graphviz 5 | expect_test_sexp_diff incremental incremental_skeleton incremental_debug 6 | core_unix.time_ns_unix core_kernel.timing_wheel) 7 | (flags :standard -w -60) 8 | (preprocess 9 | (pps ppx_jane))) 10 | 11 | (rule 12 | (targets import.ml incremental_test.ml incremental_test.mli test_config.ml 13 | test_config.mli test_for_analyzer.ml test_for_analyzer.mli 14 | test_generics.ml test_generics.mli test_incremental.ml 15 | test_incremental.mli test_exceptional_behavior.ml 16 | test_exceptional_behavior.mli test_let_syntax.ml test_let_syntax.mli 17 | test_skeleton.ml test_skeleton.mli) 18 | (deps 19 | (:first_dep generate_debug_test_lib.sh) 20 | (glob_files ../test/*.ml) 21 | (glob_files ../test/*.mli)) 22 | (action 23 | (bash ./%{first_dep}))) 24 | 25 | (rule 26 | (targets explicit_dependencies.ml explicit_dependencies.mli) 27 | (deps %{workspace_root}/bin/gen-explicit-dependencies.sh) 28 | (action 29 | (bash "%{deps} incremental"))) 30 | -------------------------------------------------------------------------------- /src/scope.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | module Node = Types.Node 4 | include Types.Scope 5 | 6 | let top = Top 7 | let get_top () = Top 8 | 9 | let is_top = function 10 | | Top -> true 11 | | Bind _ -> false 12 | ;; 13 | 14 | let invariant = function 15 | | Top -> () 16 | | Bind bind -> Bind.invariant ignore ignore bind 17 | ;; 18 | 19 | (* Unlike for nodes, there is no invariant [is_necessary t <=> height > -1] (doesn't work 20 | because of [Top]). This is fine since the height of a scope is only used to constrain 21 | other heights, not to schedule it. *) 22 | let height = function 23 | | Top -> -1 24 | | Bind bind -> bind.lhs_change.height 25 | ;; 26 | 27 | let is_valid = function 28 | | Top -> true 29 | | Bind bind -> Bind.is_valid bind 30 | ;; 31 | 32 | let is_necessary = function 33 | | Top -> true 34 | | Bind bind -> Node.is_necessary bind.main 35 | ;; 36 | 37 | let add_node t (node : _ Node.t) = 38 | assert (phys_equal node.created_in t); 39 | match t with 40 | | Top -> () 41 | | Bind bind -> 42 | node.next_node_in_same_scope <- bind.all_nodes_created_on_rhs; 43 | bind.all_nodes_created_on_rhs <- Uopt.some (Types.Node.Packed.T node) 44 | ;; 45 | -------------------------------------------------------------------------------- /step_function/src/incremental_step_function.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Time_ns = struct 4 | include Time_ns 5 | 6 | let sexp_of_t = Time_ns.Alternate_sexp.sexp_of_t 7 | end 8 | 9 | type 'a t = 10 | { init : 'a 11 | ; steps : (Time_ns.t * 'a) Sequence.t 12 | } 13 | [@@deriving fields ~getters, sexp_of] 14 | 15 | let invariant invariant_a { init; steps = _ } = invariant_a init 16 | 17 | let rec value_internal init steps ~at = 18 | match Sequence.next steps with 19 | | None -> init 20 | | Some ((t, a), steps) -> 21 | if Time_ns.( < ) at t then init else value_internal a steps ~at 22 | ;; 23 | 24 | let value t ~at = value_internal t.init t.steps ~at 25 | let constant init = { init; steps = Sequence.get_empty () } 26 | 27 | let create_exn ~init ~steps = 28 | if not 29 | (List.is_sorted steps ~compare:(fun (time1, _) (time2, _) -> 30 | Time_ns.compare time1 time2)) 31 | then 32 | raise_s 33 | [%message 34 | "[Step_function.create_exn] got unsorted times" 35 | ~steps:(steps |> List.map ~f:fst : Time_ns.t list)]; 36 | { init; steps = steps |> Sequence.of_list } 37 | ;; 38 | 39 | let create_from_sequence ~init ~steps = { init; steps } 40 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2008--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/alarm_value.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | 4 | module Action = struct 5 | type t = Types.Alarm_value.Action.t = 6 | | At of At.t 7 | | At_intervals of At_intervals.t 8 | | Snapshot : _ Snapshot.t -> t 9 | | Step_function : _ Step_function_node.t -> t 10 | [@@deriving sexp_of] 11 | 12 | let invariant = function 13 | | At at -> At.invariant at 14 | | At_intervals at_intervals -> At_intervals.invariant at_intervals 15 | | Snapshot snapshot -> Snapshot.invariant ignore snapshot 16 | | Step_function step_function_node -> 17 | Step_function_node.invariant ignore step_function_node 18 | ;; 19 | end 20 | 21 | type t = Types.Alarm_value.t = 22 | { action : Action.t 23 | ; (* [next_fired] singly links all alarm values that fire during a single call to 24 | [advance_clock]. *) 25 | mutable next_fired : (t Uopt.t[@sexp.opaque]) 26 | } 27 | [@@deriving fields ~iterators:iter, sexp_of] 28 | 29 | let invariant t = 30 | Invariant.invariant t [%sexp_of: t] (fun () -> 31 | let check f = Invariant.check_field t f in 32 | Fields.iter ~action:(check Action.invariant) ~next_fired:ignore) 33 | ;; 34 | 35 | let create action = { action; next_fired = Uopt.get_none () } 36 | -------------------------------------------------------------------------------- /test/test_generics.ml: -------------------------------------------------------------------------------- 1 | (* This code tests that generic functions can operate on [Incremental.Make] values. *) 2 | 3 | open! Core 4 | open! Import 5 | module I = Incremental.Make () 6 | 7 | let%expect_test _ = 8 | let i = I.return () in 9 | let (_ : _) = Incremental.map i ~f:Fn.id in 10 | let o = I.observe i in 11 | let (_ : _) = Incremental.Observer.value o in 12 | let v = I.Var.create () in 13 | let (_ : _) = Incremental.Var.value v in 14 | let (_ : _) = Incremental.Scope.within I.State.t I.Scope.top ~f:Fn.id in 15 | let (_ : _) = Incremental.Clock.now (I.Clock.create ~start:Time_ns.epoch ()) in 16 | let (_ : _) = 17 | Incremental.Expert.Node.add_dependency 18 | (I.Expert.Node.create Fn.id) 19 | (I.Expert.Dependency.create i) 20 | in 21 | [%expect {| |}] 22 | ;; 23 | 24 | let%expect_test "[State.create]" = 25 | let module I = (val Incremental.State.create ()) in 26 | let state = I.t in 27 | let (_ : (int, I.state_witness) Incremental.t) = Incremental.const state 13 in 28 | () 29 | ;; 30 | 31 | let%expect_test "[sexp_of_state_witness]" = 32 | let module I = (val Incremental.State.create ()) in 33 | ignore ([%sexp (I.t : I.state_witness Incremental.State.t)] : Sexp.t) 34 | ;; 35 | -------------------------------------------------------------------------------- /src/unordered_array_fold.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An [('a, 'acc) Unordered_array_fold.t] is a kind of DAG node, where ['a] is the type 4 | of value being folded and ['acc] is the type of the accumulator. *) 5 | 6 | open! Core 7 | open! Import 8 | 9 | include module type of struct 10 | include Types.Unordered_array_fold 11 | end 12 | 13 | include Invariant.S2 with type ('a, 'acc) t := ('a, 'acc) t 14 | include Sexp_of.S2 with type ('a, 'acc) t := ('a, 'acc) t 15 | 16 | module Update : sig 17 | type ('a, 'b) t = 18 | | F_inverse of ('b -> 'a -> 'b) 19 | | Update of ('b -> old_value:'a -> new_value:'a -> 'b) 20 | [@@deriving sexp_of] 21 | end 22 | 23 | val create 24 | : init:'acc 25 | -> f:('acc -> 'a -> 'acc) 26 | -> update:('a, 'acc) Update.t 27 | -> full_compute_every_n_changes:int 28 | -> children:'a Types.Node.t array 29 | -> main:'acc Types.Node.t 30 | -> ('a, 'acc) t 31 | 32 | val compute : (_, 'acc) t -> 'acc 33 | 34 | val child_changed 35 | : ('a, _) t 36 | -> child:'b Types.Node.t 37 | -> child_index:int 38 | -> old_value_opt:'b Uopt.t 39 | -> new_value:'b 40 | -> unit 41 | 42 | val force_full_compute : (_, _) t -> unit 43 | -------------------------------------------------------------------------------- /src/expert.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An [Expert.t] is the only kind of node that can update its value and set of children 4 | incrementally. The operations to change the set of children and to react to various 5 | events (new value in a child etc) are exposed to the user. *) 6 | 7 | open! Core 8 | open! Import 9 | 10 | include module type of struct 11 | include Types.Expert 12 | end 13 | 14 | include Invariant.S1 with type 'a t := 'a t 15 | include Sexp_of.S1 with type 'a t := 'a t 16 | 17 | val sexp_of_edge : ('a -> Sexp.t) -> 'a edge -> Sexp.t 18 | val invariant_about_num_invalid_children : _ t -> is_necessary:bool -> unit 19 | 20 | val create 21 | : f:(unit -> 'a) 22 | -> on_observability_change:(is_now_observable:bool -> unit) 23 | -> 'a t 24 | 25 | val make_stale : _ t -> [ `Already_stale | `Ok ] 26 | val incr_invalid_children : _ t -> unit 27 | val decr_invalid_children : _ t -> unit 28 | 29 | (** Returns the index of this new edge. *) 30 | val add_child_edge : _ t -> packed_edge -> int 31 | 32 | val swap_children : _ t -> child_index1:int -> child_index2:int -> unit 33 | val last_child_edge_exn : _ t -> packed_edge 34 | val remove_last_child_edge_exn : _ t -> unit 35 | val before_main_computation : _ t -> [ `Invalid | `Ok ] 36 | val observability_change : _ t -> is_now_observable:bool -> unit 37 | val run_edge_callback : _ t -> child_index:int -> unit 38 | -------------------------------------------------------------------------------- /src/if_then_else.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | type 'a t = 'a Types.If_then_else.t = 7 | { main : 'a Node.t 8 | ; test : bool Node.t 9 | ; test_change : unit Node.t 10 | ; mutable current_branch : 'a Node.t Uopt.t 11 | ; then_ : 'a Node.t 12 | ; else_ : 'a Node.t 13 | } 14 | [@@deriving fields ~iterators:iter, sexp_of] 15 | 16 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 17 | 18 | let invariant _invariant_a t = 19 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 20 | let check f = Invariant.check_field t f in 21 | Fields.iter 22 | ~main: 23 | (check (fun (main : _ Node.t) -> 24 | match main.kind with 25 | | Invalid -> () 26 | | If_then_else t' -> assert (phys_equal t t') 27 | | _ -> ())) 28 | ~test:ignore 29 | ~test_change: 30 | (check (fun (test_change : _ Node.t) -> 31 | match test_change.kind with 32 | | Invalid -> () 33 | | If_test_change t' -> assert (same t t') 34 | | _ -> assert false)) 35 | ~current_branch: 36 | (check (fun current_branch -> 37 | if Uopt.is_some current_branch 38 | then ( 39 | let current_branch = Uopt.value_exn current_branch in 40 | assert ( 41 | phys_equal current_branch t.then_ || phys_equal current_branch t.else_)))) 42 | ~then_:ignore 43 | ~else_:ignore) 44 | ;; 45 | -------------------------------------------------------------------------------- /memoize/README.md: -------------------------------------------------------------------------------- 1 | # Incr_memoize 2 | 3 | A library for memoizing incremental bind. 4 | 5 | Overview 6 | -------- 7 | 8 | Using `bind` in incremental code is often expensive - it causes the computation below the 9 | bind to be discarded, and recomputed from scratch. Sometimes you can just use `map` instead 10 | (see e.g. [incremental tutorial](../incremental/doc/part2-dynamic.mdx) 11 | - `if_with_map` vs `if_with_bind`), but often you don't get the choice. 12 | 13 | This can be tackled by keeping multiple computations, corresponding to different values of 14 | nodes you bind to, and selecting the correct one below bind. 15 | 16 | This library makes this super easy to do - by providing a Incr.bind replacement with 17 | memoization super-powers. Basically, you can just replace 18 | 19 | ```ocaml 20 | let%bind.Incr x = x in 21 | following_computation x 22 | ``` 23 | 24 | with 25 | 26 | ```ocaml 27 | module Incr_memoize = Incr_memoize.Make(Incr) 28 | 29 | let%bind.Incr_memoize x = Incr_memoize.with_params x store_params in 30 | following_computation x 31 | ``` 32 | 33 | It's almost drop-in, with the caveat that you need to provide some extra parameters for 34 | configuring your memoization - stuff like a comparator, caching policy etc, 35 | see `Incr_memoize.Store_params`. 36 | 37 | See the tests for an example usage. 38 | 39 | It is perfectly fine to call Incr_memoize.bind multiple times - bind to a few things one 40 | after another, mix it with `Incr.bind`, `map`, use different `store_params` etc. Just keep in 41 | mind, caching is most effective when you bind to things that only take few different values. 42 | -------------------------------------------------------------------------------- /src/ppx_assert_lib.mli: -------------------------------------------------------------------------------- 1 | (*_ This is a copy of Ppx_assert_lib.Runtime while I'm waiting for the actual runtime to 2 | be portable. The reason that the original Ppx_assert_lib isn't portable is because of 3 | the mutable string diffing function that it uses. *) 4 | 5 | open Base 6 | 7 | module Runtime : sig 8 | type 'a test_pred = 9 | ?here:Lexing.position list -> ?message:string -> ('a -> bool) -> 'a -> unit 10 | 11 | type 'a test_eq = 12 | ?here:Lexing.position list 13 | -> ?message:string 14 | -> ?equal:('a -> 'a -> bool) 15 | -> 'a 16 | -> 'a 17 | -> unit 18 | 19 | type 'a test_result = 20 | ?here:Lexing.position list 21 | -> ?message:string 22 | -> ?equal:('a -> 'a -> bool) 23 | -> expect:'a 24 | -> 'a 25 | -> unit 26 | 27 | (** Functions called by the generated code *) 28 | 29 | val test_pred 30 | : 'a. 31 | pos:string 32 | -> sexpifier:('a -> Sexp.t) 33 | -> here:Lexing.position list 34 | -> ?message:string 35 | -> ('a -> bool) 36 | -> 'a 37 | -> unit 38 | 39 | val test_eq 40 | : 'a. 41 | pos:string 42 | -> sexpifier:('a -> Sexp.t) 43 | -> comparator:('a -> 'a -> int) 44 | -> here:Lexing.position list 45 | -> ?message:string 46 | -> ?equal:('a -> 'a -> bool) 47 | -> 'a 48 | -> 'a 49 | -> unit 50 | 51 | val test_result 52 | : 'a. 53 | pos:string 54 | -> sexpifier:('a -> Sexp.t) 55 | -> comparator:('a -> 'a -> int) 56 | -> here:Lexing.position list 57 | -> ?message:string 58 | -> ?equal:('a -> 'a -> bool) 59 | -> expect:'a 60 | -> got:'a 61 | -> unit 62 | end 63 | -------------------------------------------------------------------------------- /test/test_config.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | let%expect_test "default timing-wheel precision and level durations" = 5 | let module I = Incremental.Make () in 6 | let config = I.Clock.default_timing_wheel_config in 7 | let durations = Timing_wheel.Config.durations config in 8 | require (Time_ns.Span.( >= ) (List.last_exn durations) Time_ns.Span.day); 9 | print_s 10 | [%message 11 | "" 12 | ~alarm_precision:(Timing_wheel.Config.alarm_precision config : Time_ns.Span.t) 13 | (durations : Time_ns.Span.t list)]; 14 | [%expect 15 | {| 16 | ((alarm_precision 1.048576ms) 17 | (durations ( 18 | 17.179869184s 19 | 1d15h5m37.488355328s 20 | 52d2h59m59.627370496s 21 | 104d5h59m59.254740992s 22 | 208d11h59m58.509481984s 23 | 416d23h59m57.018963968s 24 | 833d23h59m54.037927936s 25 | 1667d23h59m48.075855872s 26 | 3335d23h59m36.151711744s 27 | 6671d23h59m12.303423488s 28 | 13343d23h58m24.606846976s 29 | 26687d23h56m49.213693952s 30 | 53375d23h53m38.427387903s))) 31 | |}] 32 | ;; 33 | 34 | let%expect_test "default timing wheel can handle the full range of times" = 35 | let module I = Incremental.Make () in 36 | let open I in 37 | let clock = Clock.create ~start:Time_ns.epoch () in 38 | let o = observe (Clock.at clock Time_ns.max_value_representable) in 39 | let show_o () = print_s [%sexp (o : Before_or_after.t Observer.t)] in 40 | stabilize (); 41 | show_o (); 42 | [%expect {| Before |}]; 43 | Clock.advance_clock clock ~to_:Time_ns.max_value_representable; 44 | stabilize (); 45 | show_o (); 46 | [%expect {| After |}] 47 | ;; 48 | -------------------------------------------------------------------------------- /src/bind.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | An [('a, 'b) Bind.t] is stored inside a bind node where the left-hand side is of type 4 | ['a], and the right-hand side is of type ['b Node.t]. 5 | 6 | Each bind [t] has [t.lhs_change : unit Node.t] that is used to detect when [t.lhs] 7 | changes. Computing [t.lhs_change] restructures the graph by calling [t.f] and 8 | replacing [t.rhs] with the result. 9 | 10 | Each bind tracks the set of nodes created on its right-hand side, as a singly-linked 11 | list [t.all_nodes_created_on_rhs]. This is used to invalidate all those nodes when the 12 | [t.lhs] changes. 13 | 14 | The key invariant of a bind node [t] is: 15 | 16 | [t.lhs_change.height < node.height] for all necessary [node]s in 17 | [t.all_nodes_created_on_rhs]. 18 | 19 | This ensures that a node created on the right-hand side is not computed unless the 20 | left-hand side is stable. 21 | 22 | The graph manipulation done when [t.lhs_change] fires can't be done when [t.lhs] 23 | fires, because [t.main] could be itself created inside a bind, and this bind's lhs is 24 | not guaranteed to be stable when [t.lhs] fires (but it is guaranteed to be stable when 25 | [t.lhs_change] fires). *) 26 | 27 | open! Core 28 | open! Import 29 | 30 | include module type of struct 31 | include Types.Bind 32 | end 33 | 34 | include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t 35 | include Sexp_of.S2 with type ('a, 'b) t := ('a, 'b) t 36 | 37 | (** [is_valid t] iff the scope in which [t] was created is valid. *) 38 | val is_valid : (_, _) t -> bool 39 | 40 | val iter_nodes_created_on_rhs : (_, _) t -> f:(Types.Node.Packed.t -> unit) -> unit 41 | -------------------------------------------------------------------------------- /src-debug/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name incremental_debug) 3 | (libraries core_kernel.balanced_reducer core incremental_step_function 4 | core_kernel.thread_safe_queue core_kernel.timing_wheel uopt 5 | core_kernel.weak_hashtbl) 6 | (preprocessor_deps debug.mlh) 7 | (preprocess 8 | (pps ppx_jane ppx_optcomp))) 9 | 10 | (rule 11 | (targets adjust_heights_heap.ml adjust_heights_heap.mli alarm.ml alarm.mli 12 | alarm_value.ml alarm_value.mli array_fold.ml array_fold.mli 13 | at_intervals.ml at_intervals.mli at.ml at.mli before_or_after.ml 14 | before_or_after.mli bind.ml bind.mli config_intf.ml config.ml config.mli 15 | cutoff.ml cutoff.mli dot_user_info.ml dot_user_info.mli expert1.ml 16 | expert1.mli expert.ml expert.mli for_analyzer_intf.ml for_analyzer.ml 17 | for_analyzer.mli freeze.ml freeze.mli if_then_else.ml if_then_else.mli 18 | import.ml incremental_debug_intf.ml incremental_debug.ml 19 | incremental_debug.mli internal_observer.ml internal_observer.mli join.ml 20 | join.mli kind.ml kind.mli node_id.ml node_id.mli node.ml node.mli 21 | node_to_dot.ml node_to_dot.mli observer.ml observer.mli 22 | on_update_handler.ml on_update_handler.mli ppx_assert_lib.ml 23 | ppx_assert_lib.mli raised_exn.ml raised_exn.mli recompute_heap.ml 24 | recompute_heap.mli reduce_balanced.ml reduce_balanced.mli scope.ml 25 | scope.mli sexp_of.ml snapshot.ml snapshot.mli stabilization_num.ml 26 | stabilization_num.mli state.ml step_function_node.ml 27 | step_function_node.mli types.ml unordered_array_fold.ml 28 | unordered_array_fold.mli var.ml var.mli) 29 | (deps 30 | (glob_files ../src/*.ml) 31 | (glob_files ../src/*.mli) 32 | ./generate_debug_lib.sh) 33 | (action 34 | (bash ./generate_debug_lib.sh))) 35 | -------------------------------------------------------------------------------- /step_function/test/test_step_function.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Expect_test_helpers_base 3 | module Step_function = Incremental_step_function 4 | open! Step_function 5 | 6 | module _ = struct 7 | type t = int Step_function.t [@@deriving sexp_of] 8 | end 9 | 10 | let show t = print_s [%sexp (t : int t)] 11 | let time = Time_ns.of_int_ns_since_epoch 12 | let value t ~at = print_s [%sexp (value t ~at:(time at) : int)] 13 | 14 | let create_exn ~init ~steps = 15 | create_exn ~init ~steps:(List.map steps ~f:(fun (i, a) -> time i, a)) 16 | ;; 17 | 18 | let%expect_test "[constant]" = 19 | let t = constant 13 in 20 | invariant ignore t; 21 | show t; 22 | [%expect {| ((init 13) (steps ())) |}]; 23 | value t ~at:0; 24 | [%expect {| 13 |}] 25 | ;; 26 | 27 | let%expect_test "empty [~steps] is same as constant" = 28 | show (create_exn ~init:13 ~steps:[]); 29 | [%expect {| ((init 13) (steps ())) |}] 30 | ;; 31 | 32 | let%expect_test "[create_exn] raise" = 33 | require_does_raise ~hide_positions:true (fun () -> 34 | create_exn ~init:13 ~steps:[ 1, 14; 0, 15 ]); 35 | [%expect 36 | {| 37 | ("[Step_function.create_exn] got unsorted times" 38 | (steps ("1970-01-01 00:00:00.000000001Z" "1970-01-01 00:00:00Z"))) 39 | |}] 40 | ;; 41 | 42 | let%expect_test "steps" = 43 | let t = create_exn ~init:13 ~steps:[ 1, 14; 1, 15; 2, 16 ] in 44 | invariant ignore t; 45 | show t; 46 | [%expect 47 | {| 48 | ((init 13) 49 | (steps ( 50 | ("1970-01-01 00:00:00.000000001Z" 14) 51 | ("1970-01-01 00:00:00.000000001Z" 15) 52 | ("1970-01-01 00:00:00.000000002Z" 16)))) 53 | |}]; 54 | value t ~at:0; 55 | [%expect {| 13 |}]; 56 | value t ~at:1; 57 | [%expect {| 15 |}]; 58 | value t ~at:2; 59 | [%expect {| 16 |}]; 60 | value t ~at:3; 61 | [%expect {| 16 |}] 62 | ;; 63 | -------------------------------------------------------------------------------- /src/var.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | module Node = Types.Node 4 | 5 | type 'a t = 'a Types.Var.t = 6 | { mutable value : 'a 7 | ; (* [value_set_during_stabilization] is only set to [Uopt.some] if the user calls 8 | [Var.set] during stabilization, in which case it holds the (last) value set. At 9 | the end of stabilization, all such variables are processed to do [t.value <- 10 | t.value_set_during_stabilization]. *) 11 | mutable value_set_during_stabilization : 'a Uopt.t 12 | ; (* [set_at] the stabilization number in effect the most recent time [t.value] changed. 13 | This is not necessarily the same as the stabilization number in effect the most 14 | recent time [Var.set t] was called, due to the effect of [Var.set] during 15 | stabilization being delayed until after the stabilization. *) 16 | mutable set_at : Stabilization_num.t 17 | ; watch : 'a Node.t 18 | } 19 | [@@deriving fields ~iterators:iter, sexp_of] 20 | 21 | let invariant invariant_a t = 22 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 23 | let check f = Invariant.check_field t f in 24 | Fields.iter 25 | ~value:(check invariant_a) 26 | ~value_set_during_stabilization:(check (Uopt.invariant invariant_a)) 27 | ~set_at:(check Stabilization_num.invariant) 28 | ~watch: 29 | (check (fun (watch : _ Node.t) -> 30 | match watch.kind with 31 | | Invalid -> () (* possible with [~use_current_scope:true] *) 32 | | Var t' -> assert (phys_equal t t') 33 | | _ -> assert false))) 34 | ;; 35 | 36 | let incr_state t = t.watch.state 37 | 38 | module Packed = struct 39 | type 'a var = 'a t [@@deriving sexp_of] 40 | type t = Types.Var.Packed.t = T : _ var -> t [@@unboxed] [@@deriving sexp_of] 41 | end 42 | 43 | let latest_value t = 44 | if Uopt.is_some t.value_set_during_stabilization 45 | then Uopt.unsafe_value t.value_set_during_stabilization 46 | else t.value 47 | ;; 48 | -------------------------------------------------------------------------------- /doc/index.mdx: -------------------------------------------------------------------------------- 1 | # An Introduction to Incremental 2 | 3 | Incremental is a tool for optimizing the /incremental performance/ of 4 | your code. In other words, incremental makes it easier to build 5 | computations that update efficiently when their input data changes in 6 | small ways. 7 | 8 | It's a useful tool, but one that a lot of people don't feel entirely 9 | comfortable with. It's also a tool that's easy to misuse, which can 10 | leave you with confusing code and hard-to-predict behavior. 11 | 12 | But all in, if you know how to approach it, Incremental is powerful, 13 | and can simplify certain tasks immensely. 14 | 15 | This guide will give you an overview of the library, explaining what 16 | kinds of problems Incremental can help with, and some tips for making 17 | the most out of it. 18 | 19 | The tutorial is broken up into parts: 20 | 21 | - [Preliminaries](./part1-preliminaries.mdx) covers what Incremental 22 | is for, and walks through the basics. 23 | - [Dynamic computations with bind](./part2-dynamic.mdx) shows you 24 | how to use `bind` to build computations whose structure changes 25 | dynamically over time. 26 | - [Incr_map](./part3-map.mdx) shows you how to use the `Incr_map` 27 | libraries to build efficient computations on `Map.t`'s. 28 | - [Pitfalls](./part4-pitfalls.mdx) highlights some of the mistakes 29 | people typically make when first using Incremental. 30 | - [Time](./part5-time.mdx) demonstrates Incremental's support for 31 | building computations over time. 32 | - [Patterns](./part6-patterns.mdx) covers `ppx_pattern_bind`, 33 | which provides specialized support for doing incremental 34 | computations involving pattern matches. 35 | - [Performance and optimization](./part7-optimization.mdx) has some 36 | notes on how to think about performance of your incremental 37 | programs. 38 | - [Sharing](./part8-sharing.mdx) shows you how to optimize your 39 | incremental programs further by sharing sub-computations among 40 | different parts of your computation. 41 | 42 | -------------------------------------------------------------------------------- /src/step_function_node.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Alarm_value = Types.Alarm_value 5 | module Node = Types.Node 6 | 7 | type 'a t = 'a Types.Step_function_node.t = 8 | { main : 'a Node.t 9 | ; mutable child : 'a Step_function.t Node.t Uopt.t 10 | ; mutable extracted_step_function_from_child_at : Stabilization_num.t 11 | ; mutable value : 'a Uopt.t 12 | ; mutable upcoming_steps : (Time_ns.t * 'a) Sequence.t 13 | ; mutable alarm : Alarm.t 14 | ; mutable alarm_value : (Alarm_value.t[@sexp.opaque]) 15 | ; clock : (Types.Clock.t[@sexp.opaque]) 16 | } 17 | [@@deriving fields ~iterators:iter, sexp_of] 18 | 19 | let phys_same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 20 | 21 | let invariant invariant_a t = 22 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 23 | let check f = Invariant.check_field t f in 24 | Fields.iter 25 | ~main: 26 | (check (fun (main : _ Node.t) -> 27 | match main.kind with 28 | | Invalid -> () 29 | | Const _ -> () (* happens when [upcoming_steps] becomes empty. *) 30 | | Step_function t' -> assert (phys_equal t t') 31 | | _ -> assert false)) 32 | ~child:ignore 33 | ~extracted_step_function_from_child_at:ignore 34 | ~value:(check (Uopt.invariant invariant_a)) 35 | ~upcoming_steps:ignore 36 | ~alarm:(check Alarm.invariant) 37 | ~alarm_value: 38 | (check (fun (alarm_value : Alarm_value.t) -> 39 | match alarm_value.action with 40 | | Step_function t2 -> assert (phys_same t t2) 41 | | _ -> assert false)) 42 | ~clock:ignore) 43 | ;; 44 | 45 | let rec advance_internal t ~to_ a1 steps = 46 | match Sequence.next steps with 47 | | Some ((step_at, a2), steps2) when Time_ns.( >= ) to_ step_at -> 48 | advance_internal t ~to_ a2 steps2 49 | | _ -> 50 | t.value <- Uopt.some a1; 51 | t.upcoming_steps <- steps 52 | ;; 53 | 54 | let advance t ~to_ = advance_internal t ~to_ (Uopt.value_exn t.value) t.upcoming_steps 55 | -------------------------------------------------------------------------------- /test/test_non_debug.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (* Any tests in this file are here because they should not be run in the copy of 4 | the test suite that runs incremental in debug mode. Each test should have a 5 | comment with the reason that it is in this file. *) 6 | 7 | (* Debug-enabled incremental allocates a bunch of words during stabilization, 8 | so we only run this test for non-debug incremental. *) 9 | let%expect_test "stabilization that propagates values through an existing graph should \ 10 | not allocate" 11 | = 12 | let module I = Incremental.Make () in 13 | let open I in 14 | let v' = Var.create 0 in 15 | let v = map (Var.watch v') ~f:(( + ) 1) in 16 | let w' = Var.create 0 in 17 | let w = map (Var.watch w') ~f:(( + ) 1) in 18 | let a = map v ~f:(( + ) 1) in 19 | let b = map w ~f:(( + ) 1) in 20 | let o = observe (map2 ~f:( + ) a b) in 21 | (* The first stabilization allocates, but the next two do not. The 22 | point is that stabilization shouldn't allocate anything except to create 23 | new nodes. This means that it is okay for stabilization to allocate new 24 | nodes when the rhs of a bind node changes, but if the shape of the graph 25 | has not changed, then it shouldn't allocate. 26 | 27 | I'm not exactly sure why we care about not allocating. Obviously 28 | it's a good thing to not allocate, but I don't know whether there is an 29 | intended use-case of incremental where allocation is unacceptable. 30 | Regardless, I've received CRs when modifying incremental to maintain the 31 | property of not allocating during stabilization, so I wrote this test to 32 | notify the programmer if they ever change the allocation behavior of 33 | stabilization, either on purpose or by accident. *) 34 | stabilize (); 35 | Var.set v' 4; 36 | Expect_test_helpers_core.require_no_allocation stabilize; 37 | Var.set v' 5; 38 | Var.set w' 5; 39 | Expect_test_helpers_core.require_no_allocation stabilize; 40 | Observer.disallow_future_use o 41 | ;; 42 | -------------------------------------------------------------------------------- /src/recompute_heap.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | The recompute heap holds the set of nodes such that [Node.needs_to_be_computed]. It is 4 | used during stabilization to visit the nodes that need to be computed in topological 5 | order, using the recompute heap to visit them in increasing order of height. *) 6 | 7 | open! Core 8 | open! Import 9 | 10 | type t = Types.Recompute_heap.t [@@deriving sexp_of] 11 | 12 | include Invariant.S with type t := t 13 | 14 | val create : max_height_allowed:int -> t 15 | val length : t -> int 16 | 17 | (** [max_height_allowed] is the maximum [node.height] allowed for [node] in [t]. 18 | 19 | It is an error to call [set_max_height_allowed t m] if there is a [node] in [t] with 20 | [node.height > m]. *) 21 | val max_height_allowed : t -> int 22 | 23 | val set_max_height_allowed : t -> int -> unit 24 | 25 | (** [min_height t] returns the smallest height of any element in [t], or 26 | [max_height_allowed + 1] if [length t = 0]. *) 27 | val min_height : t -> int 28 | 29 | (** [add t node] should only be called iff: 30 | 31 | {[ 32 | (not (Node.is_in_recompute_heap node)) 33 | && Node.needs_to_be_computed node 34 | && node.height <= max_height_allowed t 35 | ]} *) 36 | val add : t -> _ Node.t -> unit 37 | 38 | (** [remove t node] should only be called iff: 39 | 40 | {[ 41 | Node.is_in_recompute_heap node && not (Node.needs_to_be_computed node) 42 | ]} *) 43 | val remove : t -> _ Node.t -> unit 44 | 45 | (** [remove_min t] removes and returns a node in [t] with minimum height. [remove_min] 46 | should only be called if [length t > 0]. *) 47 | val remove_min : t -> Node.Packed.t 48 | 49 | (** [increase_height t node] should only be called when: 50 | 51 | - [node.height > node.height_in_recompute_heap] 52 | - [node.height <= max_height_allowed t] 53 | - [Node.is_in_recompute_heap node] 54 | 55 | It changes [node.height_in_recompute_heap] to equal [node.height] and adjusts [node]'s 56 | position in [t]. *) 57 | val increase_height : t -> _ Node.t -> unit 58 | -------------------------------------------------------------------------------- /src/node_to_dot.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let print_node (out : Format.formatter) ~name ~kind ~height ~user_info = 4 | let default = For_analyzer.Dot_user_info.default ~name ~kind ~height in 5 | let info = 6 | match user_info with 7 | | None -> default 8 | | Some user_info -> For_analyzer.Dot_user_info.append default user_info 9 | in 10 | Format.fprintf 11 | out 12 | "%s\n" 13 | (For_analyzer.Dot_user_info.to_string ~name (For_analyzer.Dot_user_info.to_dot info)) 14 | ;; 15 | 16 | let save_dot ~emit_bind_edges (out : Format.formatter) ts = 17 | let node_name = 18 | if am_running_test 19 | then fun _ -> "n###" 20 | else fun id -> "n" ^ For_analyzer.Node_id.to_string id 21 | in 22 | Format.fprintf out "digraph G {\n"; 23 | Format.fprintf out " rankdir = BT\n"; 24 | let seen = For_analyzer.Node_id.Hash_set.create () in 25 | let bind_edges = ref [] in 26 | For_analyzer.traverse 27 | ts 28 | ~add_node: 29 | (fun 30 | ~id 31 | ~kind 32 | ~cutoff:_ 33 | ~children 34 | ~bind_children 35 | ~user_info 36 | ~recomputed_at:_ 37 | ~changed_at:_ 38 | ~height 39 | -> 40 | let name = node_name id in 41 | Hash_set.add seen id; 42 | print_node out ~name ~kind ~height ~user_info; 43 | List.iter children ~f:(fun child_id -> 44 | Format.fprintf out " %s -> %s\n" (node_name child_id) name); 45 | List.iter bind_children ~f:(fun bind_child_id -> 46 | bind_edges := (bind_child_id, id) :: !bind_edges)); 47 | if emit_bind_edges 48 | then 49 | List.iter !bind_edges ~f:(fun (bind_child_id, id) -> 50 | if Hash_set.mem seen bind_child_id 51 | then 52 | Format.fprintf 53 | out 54 | " %s -> %s [style=dashed]\n" 55 | (node_name id) 56 | (node_name bind_child_id)); 57 | Format.fprintf out "}\n%!" 58 | ;; 59 | 60 | let save_dot_to_file ~emit_bind_edges file ts = 61 | Out_channel.with_file file ~f:(fun out -> 62 | let formatter = Format.formatter_of_out_channel out in 63 | save_dot ~emit_bind_edges formatter ts) 64 | ;; 65 | -------------------------------------------------------------------------------- /src/cutoff.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | 4 | type 'a t = 5 | (* We specialize some cutoffs to avoid an indirect function call; in particular we 6 | specialize the default (and hence overwhelmingly common) case of physical 7 | equality. *) 8 | | Always 9 | | Never 10 | | Phys_equal 11 | | Compare of ('a -> 'a -> int) 12 | | Equal of ('a -> 'a -> bool) 13 | | F of (old_value:'a -> new_value:'a -> bool) 14 | [@@deriving sexp_of] 15 | 16 | let invariant _ t = 17 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 18 | match t with 19 | | Always | Never | Phys_equal | Compare _ | Equal _ | F _ -> ()) 20 | ;; 21 | 22 | let create f = F f 23 | let of_compare f = Compare f 24 | let of_equal f = Equal f 25 | let get_never () = Never 26 | let never = Never 27 | let always = Always 28 | let get_always () = Always 29 | let poly_equal = Equal Poly.equal 30 | 31 | let should_cutoff t ~old_value ~new_value = 32 | match t with 33 | | Phys_equal -> phys_equal old_value new_value 34 | | Never -> false 35 | | Always -> true 36 | | Compare f -> f old_value new_value = 0 37 | | Equal f -> f old_value new_value 38 | | F f -> f ~old_value ~new_value 39 | ;; 40 | 41 | let equal t1 t2 = 42 | match t1, t2 with 43 | | Always, Always -> true 44 | | Always, _ -> false 45 | | Never, Never -> true 46 | | Never, _ -> false 47 | | Phys_equal, Phys_equal -> true 48 | | Phys_equal, _ -> false 49 | | Compare f1, Compare f2 -> phys_equal f1 f2 50 | | Compare _, _ -> false 51 | | Equal f1, Equal f2 -> phys_equal f1 f2 52 | | Equal _, _ -> false 53 | | F f1, F f2 -> phys_equal f1 f2 54 | | F _, _ -> false 55 | ;; 56 | 57 | let phys_equal = Phys_equal 58 | 59 | module For_analyzer = struct 60 | type 'a t' = 'a t 61 | 62 | type t = 63 | | Always 64 | | Never 65 | | Phys_equal 66 | | Compare 67 | | Equal 68 | | F 69 | [@@deriving sexp, equal] 70 | 71 | let of_cutoff (c : _ t') = 72 | match c with 73 | | Always -> Always 74 | | Never -> Never 75 | | Phys_equal -> Phys_equal 76 | | Compare _ -> Compare 77 | | Equal _ -> Equal 78 | | F _ -> F 79 | ;; 80 | 81 | let to_string t = Sexp.to_string ([%sexp_of: t] t) 82 | end 83 | -------------------------------------------------------------------------------- /test/test_let_syntax.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module I = Incremental.Make () 4 | open I 5 | 6 | let%expect_test "simple examples of [let%map] and [let%bind]" = 7 | let open I.Let_syntax in 8 | let xi = Var.create 13 in 9 | let i1 = 10 | let%map_open a = watch xi 11 | and b = watch xi in 12 | a + b 13 | in 14 | let xb = Var.create true in 15 | let i2 = 16 | let%bind_open b = watch xb in 17 | if b then return 17 else return 19 18 | in 19 | let o1 = observe i1 in 20 | let o2 = observe i2 in 21 | I.stabilize (); 22 | print_s 23 | [%message 24 | "" (Observer.value o1 : int Or_error.t) (Observer.value o2 : int Or_error.t)]; 25 | [%expect 26 | {| 27 | (("Observer.value o1" (Ok 26)) 28 | ("Observer.value o2" (Ok 17))) 29 | |}] 30 | ;; 31 | 32 | let%expect_test "simple example of using map3 via [let%mapn]" = 33 | let open I.Let_syntax in 34 | let x = Var.create 13 in 35 | let y = Var.create 42 in 36 | let z = Var.create 12 in 37 | let xyz = 38 | let%mapn x = Var.watch x 39 | and y = Var.watch y 40 | and z = Var.watch z in 41 | x, y, z 42 | in 43 | let o = observe xyz in 44 | I.stabilize (); 45 | print_s [%message (Observer.value o : (int * int * int) Or_error.t)]; 46 | [%expect {| ("Observer.value o" (Ok (13 42 12))) |}]; 47 | Var.set x 100; 48 | I.stabilize (); 49 | print_s [%message (Observer.value o : (int * int * int) Or_error.t)]; 50 | [%expect {| ("Observer.value o" (Ok (100 42 12))) |}] 51 | ;; 52 | 53 | let%expect_test "simple example of using bind3 via [let%bindn]" = 54 | let open I.Let_syntax in 55 | let x = Var.create 13 in 56 | let y = Var.create 42 in 57 | let z = Var.create 12 in 58 | let xyz = 59 | let%bindn x = Var.watch x 60 | and y = Var.watch y 61 | and z = Var.watch z in 62 | return (x, y, z) 63 | in 64 | let o = observe xyz in 65 | I.stabilize (); 66 | print_s [%message (Observer.value o : (int * int * int) Or_error.t)]; 67 | [%expect {| ("Observer.value o" (Ok (13 42 12))) |}]; 68 | Var.set x 100; 69 | I.stabilize (); 70 | print_s [%message (Observer.value o : (int * int * int) Or_error.t)]; 71 | [%expect {| ("Observer.value o" (Ok (100 42 12))) |}] 72 | ;; 73 | -------------------------------------------------------------------------------- /test/test_exceptional_behavior.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module I = Incremental.Make () 4 | open I 5 | 6 | exception My_exn [@@deriving sexp] 7 | 8 | let my_function_that_fails () = 9 | let r = raise My_exn in 10 | print_endline "putting this here to keep the function from being TCO'd"; 11 | r 12 | ;; 13 | 14 | let require_does_raise here f = 15 | (* capture the exception with [show_backtrace] set to [true] *) 16 | Expect_test_helpers_base.require_does_raise 17 | ~show_backtrace:true 18 | ~hide_positions:false 19 | ~here 20 | f; 21 | (* check it to see that our function is in the backtrace, but don't print *) 22 | let with_backtrace = Expect_test_helpers_base.expect_test_output () in 23 | if not (String.is_substring with_backtrace ~substring:"my_function_that_fails") 24 | then print_endline with_backtrace; 25 | (* re-run the function, this time just printing the message *) 26 | Expect_test_helpers_base.require_does_raise 27 | ~show_backtrace:false 28 | ~hide_positions:true 29 | ~here 30 | f 31 | ;; 32 | 33 | let%expect_test "exception handling / re-throwing" = 34 | let open I.Let_syntax in 35 | let x = Var.create () in 36 | let (y : Nothing.t I.t) = 37 | let%map () = Var.watch x in 38 | my_function_that_fails () 39 | in 40 | let o = observe y in 41 | require_does_raise [%here] (fun () -> I.stabilize ()); 42 | [%expect 43 | {| 44 | (exn.ml.Reraised 45 | "cannot stabilize -- stabilize previously raised" 46 | test_exceptional_behavior.ml.My_exn) 47 | |}]; 48 | require_does_raise [%here] (fun () -> I.stabilize ()); 49 | [%expect 50 | {| 51 | (exn.ml.Reraised 52 | "cannot stabilize -- stabilize previously raised" 53 | test_exceptional_behavior.ml.My_exn) 54 | |}]; 55 | require_does_raise [%here] (fun () -> I.Observer.value_exn o); 56 | [%expect 57 | {| 58 | (exn.ml.Reraised 59 | "Observer.value_exn called after stabilize previously raised" 60 | test_exceptional_behavior.ml.My_exn) 61 | |}]; 62 | require_does_raise [%here] (fun () -> I.Var.set x ()); 63 | [%expect 64 | {| 65 | (exn.ml.Reraised 66 | "cannot set var -- stabilization previously raised" 67 | test_exceptional_behavior.ml.My_exn) 68 | |}] 69 | ;; 70 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | [%%import "debug.mlh"] 2 | 3 | open Core 4 | 5 | (* All [assert]s and other checks throughout the code are guarded by [if debug]. The 6 | DEBUG variable is set in the lib [incremental] and unset in the lib 7 | [incremental_debug], but apart from that they are identical. Tests are run with both 8 | the production and debug lib, and users can choose to build with the debug library, if 9 | they suspect they found a bug in incremental. *) 10 | 11 | [%%if JSC_DEBUG] 12 | 13 | let debug = true 14 | 15 | [%%else] 16 | 17 | let debug = false 18 | 19 | [%%endif] 20 | 21 | let concat = String.concat 22 | let tag name a sexp_of_a = (name, a) |> [%sexp_of: string * a] 23 | 24 | module Step_function = Incremental_step_function 25 | 26 | module Time_ns = struct 27 | include Time_ns 28 | 29 | let sexp_of_t = Time_ns.Alternate_sexp.sexp_of_t 30 | end 31 | 32 | module Array = struct 33 | include Array 34 | 35 | (* Not defining aliases in production mode, since they break type specialization of 36 | array accesses. *) 37 | [%%if JSC_DEBUG] 38 | 39 | let unsafe_get = get 40 | let unsafe_set = set 41 | 42 | [%%endif] 43 | 44 | (* Requires [len >= length t]. *) 45 | let realloc t ~len a = 46 | let new_t = create ~len a in 47 | Array.blit ~src:t ~src_pos:0 ~dst:new_t ~dst_pos:0 ~len:(length t); 48 | new_t 49 | ;; 50 | end 51 | 52 | module Uopt = struct 53 | include Uopt 54 | 55 | let unsafe_value = if debug then value_exn else unsafe_value 56 | end 57 | 58 | module Uniform_array = struct 59 | include Uniform_array 60 | 61 | [%%if JSC_DEBUG] 62 | 63 | let unsafe_get = get 64 | let unsafe_set = set_with_caml_modify 65 | 66 | [%%else] 67 | 68 | (* Uniform_array is being "smart" by checking if elements are integers, but Uopt.t 69 | almost never contain integers, so the extra check to make generated code harder to 70 | read and potentially slower. *) 71 | let unsafe_set = unsafe_set_with_caml_modify 72 | let set = set_with_caml_modify 73 | 74 | [%%endif] 75 | 76 | (* Requires [len >= length t]. *) 77 | let realloc t ~len = 78 | let new_t = create ~len (Uopt.get_none ()) in 79 | blit ~src:t ~src_pos:0 ~dst:new_t ~dst_pos:0 ~len:(length t); 80 | new_t 81 | ;; 82 | end 83 | 84 | module Alarm_precision = Timing_wheel.Alarm_precision 85 | -------------------------------------------------------------------------------- /src/dot_user_info.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | 4 | module String_list = struct 5 | type t = string list [@@deriving compare, sexp] 6 | type comparator_witness = String.comparator_witness List.comparator_witness 7 | 8 | let comparator = List.comparator String.comparator 9 | end 10 | 11 | type dot = 12 | { label : Set.M(String_list).t 13 | ; attributes : string String.Map.t 14 | } 15 | [@@deriving sexp] 16 | 17 | type t = 18 | | Dot of dot 19 | | Info of Info.t 20 | | Append of 21 | { prior : t 22 | ; new_ : t 23 | } 24 | [@@deriving sexp] 25 | 26 | let info info = Info info 27 | let append prior new_ = Append { prior; new_ } 28 | 29 | let dot ~label ~attributes = 30 | let label = Set.singleton (module String_list) label in 31 | Dot { label; attributes } 32 | ;; 33 | 34 | let rec to_dot = function 35 | | Info i -> 36 | { label = Set.singleton (module String_list) [ Info.to_string_hum i ] 37 | ; attributes = String.Map.empty 38 | } 39 | | Dot dot -> dot 40 | | Append { prior; new_ } -> 41 | let prior = to_dot prior in 42 | let new_ = to_dot new_ in 43 | let label = Set.union prior.label new_.label in 44 | let attributes = 45 | Map.merge_skewed 46 | prior.attributes 47 | new_.attributes 48 | ~combine:(fun ~key:_ _left right -> right) 49 | in 50 | { label; attributes } 51 | ;; 52 | 53 | let escape_dot_string s = 54 | (* https://graphviz.org/doc/info/lang.html *) 55 | "\"" ^ String.substr_replace_all s ~pattern:"\"" ~with_:"\\\"" ^ "\"" 56 | ;; 57 | 58 | let escape_record_label s = 59 | (* https://graphviz.org/doc/info/shapes.html *) 60 | String.concat_map s ~f:(function 61 | | ('<' | '>' | '{' | '}' | '|' | '\\' | ' ') as c -> "\\" ^ String.of_char c 62 | | c -> String.of_char c) 63 | ;; 64 | 65 | let to_string ?(shape = "Mrecord") ~name { label; attributes } = 66 | let label = 67 | label 68 | |> Set.to_list 69 | |> List.map ~f:(fun cols -> 70 | "{" ^ String.concat (List.map cols ~f:escape_record_label) ~sep:"|" ^ "}") 71 | |> String.concat ~sep:"|" 72 | |> fun s -> "{" ^ s ^ "}" 73 | in 74 | let attributes = 75 | attributes 76 | |> Map.to_alist 77 | |> List.map ~f:(fun (k, v) -> 78 | sprintf {| %s=%s|} (escape_dot_string k) (escape_dot_string v)) 79 | |> String.concat ~sep:" " 80 | in 81 | sprintf {| %s [shape=%s label=%s %s]|} name shape (escape_dot_string label) attributes 82 | ;; 83 | -------------------------------------------------------------------------------- /memoize/src/incr_memoize.mli: -------------------------------------------------------------------------------- 1 | (** A library for memoizing incremental bind. See README.md *) 2 | open Core 3 | 4 | module Store_params : sig 5 | (** Represents parameters to initialize a store that will cache incremental 6 | computations. *) 7 | 8 | type 'key t 9 | 10 | (** Use a map as a backend, never remove from cache *) 11 | val map_based__store_forever : ('key, _) Comparator.Module.t -> 'key t 12 | 13 | (** Don't memoize. Behaves identically to Incr.bind *) 14 | val none : 'key t 15 | 16 | (** Use a hash table as a backend, evict the computation for the ['key] that has been 17 | least recently accessed. *) 18 | val hash_based__lru 19 | : max_size:int 20 | -> (module Hashtbl.Key_plain with type t = 'key) 21 | -> 'key t 22 | 23 | (** Use an alist as a backend, evict the computation for the ['key] that has been least 24 | recently accessed. Operations to access the memoized computation are O(max_size) on 25 | each change in ['key]. *) 26 | val alist_based__lru : equal:('key -> 'key -> bool) -> max_size:int -> 'key t 27 | 28 | (** Wraps another [_ t], and calls the provided functions every time a value is found in 29 | or added to the cache. You can use this to log or record statistics about how much 30 | benefit you're getting from memoization. *) 31 | val with_hooks : 'key t -> if_found:('key -> unit) -> if_added:('key -> unit) -> 'key t 32 | end 33 | 34 | module Store : sig 35 | type ('k, 'v) t 36 | 37 | val create : 'k Store_params.t -> ('k, 'v) t 38 | val find : ('k, 'v) t -> 'k -> 'v option 39 | val add : ('k, 'v) t -> key:'k -> value:'v -> unit 40 | end 41 | 42 | module Make (Incr : Incremental.S) : sig 43 | module Incr_with_store_params : sig 44 | type 'a t 45 | end 46 | 47 | val with_params : 'a Incr.t -> 'a Store_params.t -> 'a Incr_with_store_params.t 48 | 49 | (** Note that despite its appearance, this is not a true monad and does not satisfy the 50 | monad signature for [bind]. This exists to make [let%bind] syntax convenient. Be 51 | careful if you are trying to use this in an unconventional way. *) 52 | 53 | val bind : 'a Incr_with_store_params.t -> f:('a -> 'b Incr.t) -> 'b Incr.t 54 | val ( >>= ) : 'a Incr_with_store_params.t -> f:('a -> 'b Incr.t) -> 'b Incr.t 55 | 56 | module Let_syntax : sig 57 | module Let_syntax : sig 58 | val bind : 'a Incr_with_store_params.t -> f:('a -> 'b Incr.t) -> 'b Incr.t 59 | end 60 | end 61 | 62 | module Store_params = Store_params 63 | module Store = Store 64 | end 65 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /src/on_update_handler.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | 4 | module Previous_update_kind = struct 5 | type t = 6 | | Never_been_updated 7 | | Necessary 8 | | Changed 9 | | Invalidated 10 | | Unnecessary 11 | [@@deriving sexp_of] 12 | end 13 | 14 | module Node_update = struct 15 | type 'a t = 16 | | Necessary of 'a 17 | | Changed of 'a * 'a 18 | | Invalidated 19 | | Unnecessary 20 | [@@deriving compare, sexp_of] 21 | end 22 | 23 | type 'a t = 24 | { f : 'a Node_update.t -> unit 25 | ; mutable previous_update_kind : Previous_update_kind.t 26 | ; created_at : Stabilization_num.t 27 | } 28 | [@@deriving sexp_of] 29 | 30 | let create f ~at:created_at = { f; previous_update_kind = Never_been_updated; created_at } 31 | 32 | let really_run t (node_update : _ Node_update.t) = 33 | t.previous_update_kind 34 | <- (match node_update with 35 | | Necessary _ -> Necessary 36 | | Changed _ -> Changed 37 | | Invalidated -> Invalidated 38 | | Unnecessary -> Unnecessary); 39 | t.f node_update 40 | ;; 41 | 42 | let run t (node_update : _ Node_update.t) ~now = 43 | (* We only run the handler if was created in an earlier stabilization cycle. If the 44 | handler was created by another on-update handler during the running of on-update 45 | handlers in the current stabilization, we treat the added handler as if it were added 46 | after this stabilization finished. We will run it at the next stabilization, because 47 | the node with the handler was pushed on [state.handle_after_stabilization]. *) 48 | if Stabilization_num.compare t.created_at now < 0 49 | then ( 50 | match t.previous_update_kind, node_update with 51 | (* Once a node is invalidated, there will never be further information to provide, 52 | since incremental does not allow an invalid node to become valid. *) 53 | | Invalidated, _ -> () 54 | (* These cases can happen if a node is handled after stabilization due to another 55 | handler. But for the current handler, there is nothing to do because there is no 56 | new information to provide. *) 57 | | Changed, Necessary _ | Necessary, Necessary _ | Unnecessary, Unnecessary -> () 58 | (* If this handler hasn't seen a node that is changing, we treat the update as an 59 | initialization. *) 60 | | (Never_been_updated | Unnecessary), Changed (_, a) -> really_run t (Necessary a) 61 | (* All other updates are run as is. *) 62 | | Never_been_updated, (Necessary _ | Unnecessary | Invalidated) 63 | | Unnecessary, (Necessary _ | Invalidated) 64 | | Necessary, (Changed _ | Unnecessary | Invalidated) 65 | | Changed, (Changed _ | Unnecessary | Invalidated) -> really_run t node_update) 66 | ;; 67 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.17.0 2 | - Added `Scope.is_top` to determine if the scope is the top-level scope (outside of any 3 | binds) 4 | - Add an optional `emit_bind_edges` parameter to all `save_dot` graphviz functions 5 | which you can use to omit the dashed lines connecting bind nodes to nodes allocated in 6 | their scope 7 | - Expose `For_analyzer` module in the `Incremental` interface for traversal of `Incr` 8 | nodes for analysis purposes. 9 | 10 | ## Release v0.16.0 11 | 12 | - Add `incr_memoize` library for memoizing incremental binds. This library keeps the 13 | incremental nodes of old binds alive by storing them in a data structure. 14 | - Introduce `Store_params` submodule for configuring the memoization behavior. 15 | 16 | ## Old pre-v0.15 changelogs (very likely stale and incomplete) 17 | 18 | ## 113.43.00 19 | 20 | - Adds a `Let_syntax` module to `Incremental_intf.S`. We've found things like this 21 | useful in a couple of different projects as a nice alternative to the `mapN` 22 | functions. 23 | 24 | ## 113.33.00 25 | 26 | - Made it possible to use Incremental without invalidation -- i.e. a 27 | change in a the left-hand side of bind does *not* invalidate nodes 28 | created on the right-hand side. 29 | 30 | This is configurable via the argument to 31 | `Incremental.Make_with_config`, which now takes: 32 | 33 | val bind_lhs_change_should_invalidate_rhs : bool 34 | 35 | So, one can now build an Incremental without invalidation using: 36 | 37 | Incremental.Make_with_config (struct 38 | include Incremental.Config.Default () 39 | let bind_lhs_change_should_invalidate_rhs = false 40 | end) () 41 | 42 | Implementation 43 | -------------- 44 | The implementation is simple: 45 | When a bind rhs changes, instead of `invalidate_nodes_created_on_rhs`, 46 | we `rescope_nodes_created_on_rhs`, which moves the nodes up to 47 | the bind's parent. 48 | 49 | Testing 50 | ------- 51 | Turned the unit tests into a functor parameterized on 52 | `bind_lhs_change_should_invalidate_rhs`, and run them with both `true` 53 | and `false`. Modified tests where necessary to skip tests of 54 | invalidity when `bind_lhs_change_should_invalidate_rhs = false`. 55 | 56 | Added a unit test of `bind_lhs_change_should_invalidate_rhs = true` 57 | that makes sure a node created on a bind rhs whose lhs subsequently 58 | changes continues to stabilize correctly. 59 | 60 | - Splitted incremental into a part that can run in javascript, incremental_kernel, and the 61 | other one. 62 | 63 | ## 113.24.00 64 | 65 | - Add README.org to Incremental. 66 | 67 | - Added some type annotations based on comments by @def-lkb about lack of 68 | principality. 69 | 70 | - Switched to ppx. 71 | -------------------------------------------------------------------------------- /src/bind.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Kind 4 | module Bind = Types.Bind 5 | module Node = Types.Node 6 | module Scope = Types.Scope 7 | 8 | type ('a, 'b) t = ('a, 'b) Bind.t = 9 | { main : 'b Node.t 10 | ; (* [f] is the user-supplied function that we run each time [t.lhs] changes. It is 11 | mutable only so we can clear it when [t] is invalidated. *) 12 | mutable f : 'a -> 'b Node.t 13 | ; lhs : 'a Node.t 14 | ; lhs_change : unit Node.t 15 | ; (* [rhs] is initially [none], and after that is [some] of the result of the most recent 16 | call to [f]. *) 17 | mutable rhs : 'b Node.t Uopt.t 18 | ; (* [rhs_scope] is the scope in which [t.f] is run, i.e. it is [Scope.Bind t]. It is 19 | [mutable] only to avoid a [let rec] during creation. *) 20 | mutable rhs_scope : Scope.t 21 | ; (* [all_nodes_created_on_rhs] is the head of the singly-linked list of nodes created on 22 | the right-hand side of [t], i.e. in [t.rhs_scope]. *) 23 | mutable all_nodes_created_on_rhs : Node.Packed.t Uopt.t 24 | } 25 | [@@deriving fields ~iterators:iter, sexp_of] 26 | 27 | let same (t1 : (_, _) t) (t2 : (_, _) t) = phys_same t1 t2 28 | 29 | let is_valid t = 30 | match t.main.kind with 31 | | Invalid -> false 32 | | _ -> true 33 | ;; 34 | 35 | let iter_nodes_created_on_rhs t ~(f : Node.Packed.t -> unit) = 36 | let r = ref t.all_nodes_created_on_rhs in 37 | while Uopt.is_some !r do 38 | let (T node_on_rhs) = Uopt.unsafe_value !r in 39 | r := node_on_rhs.next_node_in_same_scope; 40 | f (T node_on_rhs) 41 | done 42 | ;; 43 | 44 | let invariant _invariant_a _invariant_b t = 45 | Invariant.invariant t [%sexp_of: (_, _) t] (fun () -> 46 | let check f = Invariant.check_field t f in 47 | Fields.iter 48 | ~main: 49 | (check (fun (main : _ Node.t) -> 50 | match main.kind with 51 | | Invalid -> () 52 | | Bind_main t' -> assert (same t t') 53 | | _ -> assert false)) 54 | ~f:ignore 55 | ~lhs:ignore 56 | ~lhs_change: 57 | (check (fun (lhs_change : _ Node.t) -> 58 | assert (phys_equal lhs_change.created_in t.main.created_in); 59 | match lhs_change.kind with 60 | | Invalid -> () 61 | | Bind_lhs_change t' -> assert (same t t') 62 | | _ -> assert false)) 63 | ~rhs:ignore 64 | ~rhs_scope: 65 | (check (function 66 | | Scope.Top -> assert false 67 | | Bind t' -> assert (same t t'))) 68 | ~all_nodes_created_on_rhs: 69 | (check (fun _ -> 70 | iter_nodes_created_on_rhs t ~f:(fun (T node) -> 71 | assert (phys_equal node.created_in t.rhs_scope); 72 | if Node.is_necessary node then assert (t.lhs_change.height < node.height))))) 73 | ;; 74 | -------------------------------------------------------------------------------- /src/for_analyzer_intf.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module type S = sig 4 | module Cutoff : sig 5 | type t = 6 | | Always 7 | | Never 8 | | Phys_equal 9 | | Compare 10 | | Equal 11 | | F 12 | [@@deriving sexp, equal] 13 | 14 | val to_string : t -> string 15 | end 16 | 17 | module Kind : sig 18 | type t = 19 | | Array_fold 20 | | At of { at : Time_ns.t } 21 | | At_intervals of 22 | { base : Time_ns.t 23 | ; interval : Time_ns.Span.t 24 | } 25 | | Bind_lhs_change 26 | | Bind_main 27 | | Const 28 | | Expert 29 | | Freeze 30 | | If_test_change 31 | | If_then_else 32 | | Invalid 33 | | Join_lhs_change 34 | | Join_main 35 | | Map 36 | | Snapshot of { at : Time_ns.t } 37 | | Step_function 38 | | Uninitialized 39 | | Unordered_array_fold 40 | | Var 41 | | Map2 42 | | Map3 43 | | Map4 44 | | Map5 45 | | Map6 46 | | Map7 47 | | Map8 48 | | Map9 49 | | Map10 50 | | Map11 51 | | Map12 52 | | Map13 53 | | Map14 54 | | Map15 55 | [@@deriving sexp] 56 | 57 | val to_string : t -> string 58 | end 59 | 60 | module Dot_user_info : sig 61 | type t [@@deriving sexp] 62 | 63 | type dot = 64 | { label : (string list, String.comparator_witness List.comparator_witness) Set.t 65 | ; attributes : string String.Map.t 66 | } 67 | [@@deriving sexp] 68 | 69 | val dot : label:string list -> attributes:string Core.String.Map.t -> t 70 | val to_dot : t -> dot 71 | val append : t -> t -> t 72 | val to_string : ?shape:string -> name:string -> dot -> string 73 | val default : name:string -> kind:Kind.t -> height:int -> t 74 | end 75 | 76 | module Stabilization_num : sig 77 | type t [@@deriving sexp] 78 | 79 | include Comparable.S with type t := t 80 | 81 | val to_string : t -> string 82 | val to_int : t -> int 83 | val is_some : t -> bool 84 | val is_none : t -> bool 85 | end 86 | 87 | module Node_id : sig 88 | type t [@@deriving sexp] 89 | 90 | include Hashable with type t := t 91 | include Comparable.S with type t := t 92 | 93 | val to_string : t -> string 94 | val to_int : t -> int 95 | val of_int : int -> t 96 | end 97 | 98 | type packed_node 99 | type _ state 100 | 101 | val node_id : packed_node -> Node_id.t 102 | val directly_observed : _ state -> packed_node list 103 | 104 | val traverse 105 | : packed_node list 106 | -> add_node: 107 | (id:Node_id.t 108 | -> kind:Kind.t 109 | -> cutoff:Cutoff.t 110 | -> children:Node_id.t list 111 | -> bind_children:Node_id.t list 112 | -> user_info:Dot_user_info.t option 113 | -> recomputed_at:Stabilization_num.t 114 | -> changed_at:Stabilization_num.t 115 | -> height:int 116 | -> unit) 117 | -> unit 118 | end 119 | -------------------------------------------------------------------------------- /src/adjust_heights_heap.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | The adjust-heights heap is used after an edge is added to the graph from a child node 4 | to a parent node. If the child's height is greater than or equal to the parent's 5 | height, then [Adjust_heights_heap.adjust_heights] increases the height of the parent 6 | and its ancestors as necessary in order to restore the height invariant. This is done 7 | by visiting ancestors in topological order, using the adjust-heights heap to visit 8 | them in increasing order of pre-adjusted height. *) 9 | 10 | open! Core 11 | open! Import 12 | open Types 13 | 14 | type t = Types.Adjust_heights_heap.t [@@deriving sexp_of] 15 | 16 | include Invariant.S with type t := t 17 | 18 | val create : max_height_allowed:int -> t 19 | val length : t -> int 20 | 21 | (** It is required that all nodes have [n.height <= max_height_allowed t]. Any attempt to 22 | set a node's height larger will raise. 23 | 24 | One can call [set_max_height_allowed] to change the maximum-allowed height. 25 | [set_max_height_allowed t m] raises if [m < max_height_seen t]. *) 26 | val max_height_allowed : t -> int 27 | 28 | val set_max_height_allowed : t -> int -> unit 29 | 30 | (** [max_height_seen t] returns the maximum height of any node ever created, not just 31 | nodes currently in use. *) 32 | val max_height_seen : t -> int 33 | 34 | (** [set_height] must be called to change the height of a node, except when clearing the 35 | height to [-1]. This allows the adjust-heights heap to track the maximum height of all 36 | nodes. [set_height] raises if [node.height > max_height_allowed t]. *) 37 | val set_height : t -> _ Node.t -> int -> unit 38 | 39 | (** [adjust_heights t recompute_heap ~child ~parent] is called when [parent] is added as a 40 | parent of [child] and [child.height >= parent.height]. It restores the node height 41 | invariant: [child.height < parent.height] (for [parent] and all its ancestors). 42 | 43 | Pre and post-conditions: 44 | 45 | - [t] is empty. Thus, for all nodes [n], [n.height_in_adjust_heights_heap = -1]. 46 | - For all nodes [n] in [recompute_heap], [n.height = n.height_in_recompute_heap]. 47 | 48 | [adjust_heights] adds a node [n] to the adjust-heights heap when it detects that 49 | [c.height >= n.height] for some child [c] of [n]. It adds [n] with 50 | [n.height_in_adjust_heights_heap] set to the pre-adjusted height of [n], and then sets 51 | [n.height] to [c.height + 1]. [adjust_heights] then does not change 52 | [n.height_in_adjust_heights_heap] until [n] is removed from [t], at which point it is 53 | reset to [-1]. [adjust_heights] may increase [n.height] further as it detects other 54 | children [c] of [n] with [c.height >= n.height]. A node's [height_in_recompute_heap] 55 | changes at most once during [adjust_heights], once the node's final adjusted height is 56 | known. 57 | 58 | Here is the algorithm. 59 | 60 | while [t] is not empty: 61 | 1. remove an [n] in [t] with minimum [n.height_in_adjust_heights_heap]. 62 | 2. [Recompute_heap.increase_height recompute_heap n]. 63 | 3. for all parents [p] of [n], if [n.height >= p.height], then ensure [p] is in [t] 64 | and set [p.height] to [n.height + 1] and 65 | 66 | If [adjust_heights] ever encounters [child] while visiting the ancestors of [parent], 67 | then there is a cycle in the graph and [adjust_heights] raises. 68 | 69 | [adjust_heights] raises if a node's height needs to be increased beyond 70 | [max_height_allowed t]. *) 71 | val adjust_heights : t -> Recompute_heap.t -> child:_ Node.t -> parent:_ Node.t -> unit 72 | -------------------------------------------------------------------------------- /src/ppx_assert_lib.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Runtime = struct 4 | type 'a test_pred = 5 | ?here:Lexing.position list -> ?message:string -> ('a -> bool) -> 'a -> unit 6 | 7 | type 'a test_eq = 8 | ?here:Lexing.position list 9 | -> ?message:string 10 | -> ?equal:('a -> 'a -> bool) 11 | -> 'a 12 | -> 'a 13 | -> unit 14 | 15 | type 'a test_result = 16 | ?here:Lexing.position list 17 | -> ?message:string 18 | -> ?equal:('a -> 'a -> bool) 19 | -> expect:'a 20 | -> 'a 21 | -> unit 22 | 23 | exception E of string * Sexp.t [@@deriving sexp] 24 | 25 | let exn_sexp_style ~message ~pos ~here ~tag body = 26 | let message = 27 | match message with 28 | | None -> tag 29 | | Some s -> s ^ ": " ^ tag 30 | in 31 | let sexp = 32 | Sexp.List 33 | (body 34 | @ [ Sexp.List [ Sexp.Atom "Loc"; Sexp.Atom pos ] ] 35 | @ 36 | match here with 37 | | [] -> [] 38 | | _ -> 39 | [ Sexp.List [ Sexp.Atom "Stack"; [%sexp_of: Source_code_position.t list] here ] 40 | ]) 41 | in 42 | (* Here and in other places we return exceptions, rather than directly raising, and 43 | instead raise at the latest moment possible, so backtrace don't include noise from 44 | these functions that construct exceptions. *) 45 | E (message, sexp) 46 | ;; 47 | 48 | let[@cold] exn_test_pred ~message ~pos ~here ~sexpifier t = 49 | exn_sexp_style 50 | ~message 51 | ~pos 52 | ~here 53 | ~tag:"predicate failed" 54 | [ Sexp.List [ Sexp.Atom "Value"; sexpifier t ] ] 55 | ;; 56 | 57 | let test_pred ~pos ~sexpifier ~here ?message predicate t = 58 | if not (predicate t) then raise (exn_test_pred ~message ~pos ~here ~sexpifier t) 59 | ;; 60 | 61 | let r_diff : (from_:string -> to_:string -> unit) option = None 62 | 63 | let[@cold] test_result_or_eq_failed ~sexpifier ~expect ~got = 64 | let got = sexpifier got in 65 | let expect = sexpifier expect in 66 | (match r_diff with 67 | | None -> () 68 | | Some diff -> 69 | let from_ = Sexp.to_string_hum expect in 70 | let to_ = Sexp.to_string_hum got in 71 | diff ~from_ ~to_); 72 | `Fail (expect, got) 73 | ;; 74 | 75 | let test_result_or_eq ~sexpifier ~comparator ~equal ~expect ~got = 76 | let pass = 77 | match equal with 78 | | None -> comparator got expect = 0 79 | | Some f -> f got expect 80 | in 81 | if pass then `Pass else test_result_or_eq_failed ~sexpifier ~expect ~got 82 | ;; 83 | 84 | let[@cold] exn_test_eq ~message ~pos ~here ~t1 ~t2 = 85 | exn_sexp_style ~message ~pos ~here ~tag:"comparison failed" [ t1; Sexp.Atom "vs"; t2 ] 86 | ;; 87 | 88 | let test_eq ~pos ~sexpifier ~comparator ~here ?message ?equal t1 t2 = 89 | match test_result_or_eq ~sexpifier ~comparator ~equal ~expect:t1 ~got:t2 with 90 | | `Pass -> () 91 | | `Fail (t1, t2) -> raise (exn_test_eq ~message ~pos ~here ~t1 ~t2) 92 | ;; 93 | 94 | let[@cold] exn_test_result ~message ~pos ~here ~expect ~got = 95 | exn_sexp_style 96 | ~message 97 | ~pos 98 | ~here 99 | ~tag:"got unexpected result" 100 | [ Sexp.List [ Sexp.Atom "expected"; expect ]; Sexp.List [ Sexp.Atom "got"; got ] ] 101 | ;; 102 | 103 | let[@warning "-16"] test_result 104 | ~pos 105 | ~sexpifier 106 | ~comparator 107 | ~here 108 | ?message 109 | ?equal 110 | ~expect 111 | ~got 112 | = 113 | match test_result_or_eq ~sexpifier ~comparator ~equal ~expect ~got with 114 | | `Pass -> () 115 | | `Fail (expect, got) -> raise (exn_test_result ~message ~pos ~here ~expect ~got) 116 | ;; 117 | end 118 | -------------------------------------------------------------------------------- /memoize/src/incr_memoize.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Store_params = struct 4 | type 'a t = 5 | | None : _ t 6 | | Map : { comparator : ('a, _) Comparator.Module.t } -> 'a t 7 | | Alist_lru : 8 | { equal : 'a -> 'a -> bool 9 | ; max_size : int 10 | } 11 | -> 'a t 12 | | Hashmap_lru : 13 | { lru : (module Lru_cache.S with type key = 'a) 14 | ; max_size : int 15 | } 16 | -> 'a t 17 | | With_hooks : 18 | { inner : 'a t 19 | ; if_found : 'a -> unit 20 | ; if_added : 'a -> unit 21 | } 22 | -> 'a t 23 | 24 | let map_based__store_forever comparator = Map { comparator } 25 | 26 | let alist_based__lru ~equal ~max_size = 27 | assert (max_size > 0); 28 | Alist_lru { equal; max_size } 29 | ;; 30 | 31 | let with_hooks inner ~if_found ~if_added = With_hooks { inner; if_found; if_added } 32 | 33 | let hash_based__lru 34 | (type key) 35 | ~max_size 36 | (module Key : Hashtbl.Key_plain with type t = key) 37 | : key t 38 | = 39 | let module Key : Lru_cache.H with type t = Key.t = struct 40 | include Key 41 | 42 | let invariant (_ : t) = () 43 | end 44 | in 45 | let lru = (module Lru_cache.Make (Key) : Lru_cache.S with type key = Key.t) in 46 | Hashmap_lru { lru; max_size } 47 | ;; 48 | 49 | let none = None 50 | end 51 | 52 | module Store = struct 53 | type ('k, 'v) t = 54 | { find : 'k -> 'v option 55 | ; add : key:'k -> value:'v -> unit 56 | } 57 | 58 | let find_or_add t ~key ~default = 59 | match t.find key with 60 | | Some value -> `Found, value 61 | | None -> 62 | let value = default () in 63 | t.add ~key ~value; 64 | `Added, value 65 | ;; 66 | 67 | let find t key = t.find key 68 | let add t ~key ~value = t.add ~key ~value 69 | 70 | let rec create : type k. k Store_params.t -> (k, _) t = 71 | fun params -> 72 | match params with 73 | | None -> 74 | let find _ = None in 75 | let add ~key:_ ~value:_ = () in 76 | { find; add } 77 | | Map { comparator } -> 78 | let cache = ref (Map.empty comparator) in 79 | let find key = Map.find !cache key in 80 | let add ~key ~value = cache := Map.set !cache ~key ~data:value in 81 | { find; add } 82 | | Alist_lru { equal; max_size } -> 83 | let cache = ref [] in 84 | let find key = 85 | match List.Assoc.find !cache ~equal key with 86 | | Some value -> 87 | cache := (key, value) :: List.Assoc.remove !cache ~equal key; 88 | Some value 89 | | None -> None 90 | in 91 | let add ~key ~value = cache := (key, value) :: List.take !cache (max_size - 1) in 92 | { find; add } 93 | | Hashmap_lru { lru; max_size } -> 94 | let (module Lru : Lru_cache.S with type key = k) = lru in 95 | let cache = Lru.create ~max_size () in 96 | let find key = Lru.find cache key in 97 | let add ~key ~value = Lru.set cache ~key ~data:value in 98 | { find; add } 99 | | With_hooks { inner; if_found; if_added } -> 100 | let inner = create inner in 101 | let find key = 102 | let res = inner.find key in 103 | if Option.is_some res then if_found key; 104 | res 105 | in 106 | let add ~key ~value = 107 | inner.add ~key ~value; 108 | if_added key 109 | in 110 | { find; add } 111 | ;; 112 | end 113 | 114 | module Make (Incr : Incremental.S) = struct 115 | module Incr_with_store_params = struct 116 | type 'a t = 'a Incr.t * 'a Store_params.t 117 | end 118 | 119 | let with_params = Tuple2.create 120 | 121 | let bind (type a) ((x, store_params) : a Incr_with_store_params.t) ~(f : a -> 'b Incr.t) 122 | : 'b Incr.t 123 | = 124 | let scope = Incr.Scope.current () in 125 | let store = Store.create store_params in 126 | let%bind.Incr x in 127 | let default () = Incr.Scope.within scope ~f:(fun () -> f x) in 128 | let (`Found | `Added), graph = Store.find_or_add store ~key:x ~default in 129 | graph 130 | ;; 131 | 132 | let ( >>= ) = bind 133 | 134 | module Let_syntax = struct 135 | module Let_syntax = struct 136 | let bind = bind 137 | end 138 | end 139 | 140 | module Store_params = Store_params 141 | module Store = Store 142 | end 143 | -------------------------------------------------------------------------------- /src/for_analyzer.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Cutoff = Cutoff.For_analyzer 3 | module Internal_node_id = Node_id 4 | 5 | module Kind = struct 6 | type t = 7 | | Array_fold 8 | | At of { at : Time_ns.Alternate_sexp.t } 9 | | At_intervals of 10 | { base : Time_ns.Alternate_sexp.t 11 | ; interval : Time_ns.Span.t 12 | } 13 | | Bind_lhs_change 14 | | Bind_main 15 | | Const 16 | | Expert 17 | | Freeze 18 | | If_test_change 19 | | If_then_else 20 | | Invalid 21 | | Join_lhs_change 22 | | Join_main 23 | | Map 24 | | Snapshot of { at : Time_ns.Alternate_sexp.t } 25 | | Step_function 26 | | Uninitialized 27 | | Unordered_array_fold 28 | | Var 29 | | Map2 30 | | Map3 31 | | Map4 32 | | Map5 33 | | Map6 34 | | Map7 35 | | Map8 36 | | Map9 37 | | Map10 38 | | Map11 39 | | Map12 40 | | Map13 41 | | Map14 42 | | Map15 43 | [@@deriving sexp] 44 | 45 | let to_string t = Sexp.to_string ([%sexp_of: t] t) 46 | end 47 | 48 | let kind (Node.Packed.T node) : Kind.t = 49 | match node.kind with 50 | | Array_fold _ -> Array_fold 51 | | At { at; _ } -> At { at } 52 | | At_intervals { base; interval; _ } -> At_intervals { base; interval } 53 | | Bind_lhs_change _ -> Bind_lhs_change 54 | | Bind_main _ -> Bind_main 55 | | Const _ -> Const 56 | | Expert _ -> Expert 57 | | Freeze _ -> Freeze 58 | | If_test_change _ -> If_test_change 59 | | If_then_else _ -> If_then_else 60 | | Invalid -> Invalid 61 | | Join_lhs_change _ -> Join_lhs_change 62 | | Join_main _ -> Join_main 63 | | Map _ -> Map 64 | | Snapshot { at; _ } -> Snapshot { at } 65 | | Step_function _ -> Step_function 66 | | Uninitialized -> Uninitialized 67 | | Unordered_array_fold _ -> Unordered_array_fold 68 | | Var _ -> Var 69 | | Map2 _ -> Map2 70 | | Map3 _ -> Map3 71 | | Map4 _ -> Map4 72 | | Map5 _ -> Map5 73 | | Map6 _ -> Map6 74 | | Map7 _ -> Map7 75 | | Map8 _ -> Map8 76 | | Map9 _ -> Map9 77 | | Map10 _ -> Map10 78 | | Map11 _ -> Map11 79 | | Map12 _ -> Map12 80 | | Map13 _ -> Map13 81 | | Map14 _ -> Map14 82 | | Map15 _ -> Map15 83 | ;; 84 | 85 | module Dot_user_info = struct 86 | include Dot_user_info 87 | 88 | let default ~name ~kind ~height = 89 | let label = 90 | [ name; Sexp.to_string ([%sexp_of: Kind.t] kind); sprintf "height=%d" height ] 91 | in 92 | Dot_user_info.dot ~label ~attributes:String.Map.empty 93 | ;; 94 | end 95 | 96 | module Node_id = Int 97 | 98 | module Stabilization_num = struct 99 | include Stabilization_num 100 | include Stabilization_num.For_analyzer 101 | end 102 | 103 | let recomputed_at (Node.Packed.T node) = node.recomputed_at 104 | let changed_at (Node.Packed.T node) = node.changed_at 105 | let node_id (Node.Packed.T node) = Internal_node_id.to_string node.id |> Node_id.of_string 106 | let cutoff (Node.Packed.T node) = Cutoff.of_cutoff node.cutoff 107 | let user_info (Node.Packed.T node) = node.user_info 108 | let height (Node.Packed.T node) = node.height 109 | let iteri_children (Node.Packed.T node) = Node.iteri_children node 110 | 111 | let maybe_iter_on_bind_nodes_created_on_rhs (Node.Packed.T node) ~f = 112 | match node.kind with 113 | | Bind_lhs_change bind -> Bind.iter_nodes_created_on_rhs bind ~f 114 | | _ -> () 115 | ;; 116 | 117 | let directly_observed = State.directly_observed 118 | 119 | let traverse packed_list ~add_node = 120 | let map_of_iter iterator ~f = 121 | let out = ref [] in 122 | iterator ~f:(fun x -> out := f x :: !out); 123 | List.rev !out 124 | in 125 | Node.Packed.iter_descendants packed_list ~f:(fun packed_node -> 126 | let children = 127 | map_of_iter 128 | (fun ~f -> iteri_children packed_node ~f:(fun _ node -> f node)) 129 | ~f:node_id 130 | in 131 | let bind_children = 132 | map_of_iter (maybe_iter_on_bind_nodes_created_on_rhs packed_node) ~f:node_id 133 | in 134 | let id = node_id packed_node in 135 | let kind = kind packed_node in 136 | let cutoff = cutoff packed_node in 137 | let user_info = user_info packed_node in 138 | let recomputed_at = recomputed_at packed_node in 139 | let changed_at = changed_at packed_node in 140 | let height = height packed_node in 141 | add_node 142 | ~id 143 | ~kind 144 | ~cutoff 145 | ~children 146 | ~bind_children 147 | ~user_info 148 | ~recomputed_at 149 | ~changed_at 150 | ~height) 151 | ;; 152 | -------------------------------------------------------------------------------- /src/unordered_array_fold.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open Types.Kind 4 | module Node = Types.Node 5 | 6 | module Update = struct 7 | type ('a, 'b) t = 8 | | F_inverse of ('b -> 'a -> 'b) 9 | | Update of ('b -> old_value:'a -> new_value:'a -> 'b) 10 | [@@deriving sexp_of] 11 | 12 | let update t ~f = 13 | match t with 14 | | Update update -> update 15 | | F_inverse f_inverse -> 16 | fun fold_value ~old_value ~new_value -> f (f_inverse fold_value old_value) new_value 17 | ;; 18 | end 19 | 20 | type ('a, 'acc) t = ('a, 'acc) Types.Unordered_array_fold.t = 21 | { main : 'acc Node.t 22 | ; init : 'acc 23 | ; f : 'acc -> 'a -> 'acc 24 | ; update : 'acc -> old_value:'a -> new_value:'a -> 'acc 25 | ; full_compute_every_n_changes : int 26 | ; children : 'a Node.t array 27 | ; mutable fold_value : 'acc Uopt.t 28 | ; mutable num_changes_since_last_full_compute : int 29 | } 30 | [@@deriving fields ~iterators:iter, sexp_of] 31 | 32 | let same (t1 : (_, _) t) (t2 : (_, _) t) = phys_same t1 t2 33 | 34 | let invariant invariant_a invariant_acc t = 35 | Invariant.invariant t [%sexp_of: (_, _) t] (fun () -> 36 | let check f = Invariant.check_field t f in 37 | Fields.iter 38 | ~main: 39 | (check (fun (main : _ Node.t) -> 40 | match main.kind with 41 | | Invalid -> () 42 | | Unordered_array_fold t' -> assert (same t t') 43 | | _ -> assert false)) 44 | ~init:(check invariant_acc) 45 | ~f:ignore 46 | ~update:ignore 47 | ~children: 48 | (check (fun children -> 49 | Array.iter children ~f:(fun (child : _ Node.t) -> 50 | Uopt.invariant invariant_a child.value_opt; 51 | if t.num_changes_since_last_full_compute < t.full_compute_every_n_changes 52 | then assert (Uopt.is_some child.value_opt)))) 53 | ~fold_value: 54 | (check (fun fold_value -> 55 | Uopt.invariant invariant_acc fold_value; 56 | [%test_result: bool] 57 | (Uopt.is_some fold_value) 58 | ~expect: 59 | (t.num_changes_since_last_full_compute < t.full_compute_every_n_changes))) 60 | ~num_changes_since_last_full_compute: 61 | (check (fun num_changes_since_last_full_compute -> 62 | assert (num_changes_since_last_full_compute >= 0); 63 | assert (num_changes_since_last_full_compute <= t.full_compute_every_n_changes))) 64 | ~full_compute_every_n_changes: 65 | (check (fun full_compute_every_n_changes -> 66 | assert (full_compute_every_n_changes > 0)))) 67 | ;; 68 | 69 | let create ~init ~f ~update ~full_compute_every_n_changes ~children ~main = 70 | { init 71 | ; f 72 | ; update = Update.update update ~f 73 | ; full_compute_every_n_changes 74 | ; children 75 | ; main 76 | ; fold_value = 77 | Uopt.get_none () 78 | (* We make [num_changes_since_last_full_compute = full_compute_every_n_changes] 79 | so that there will be a full computation the next time the node is computed. *) 80 | ; num_changes_since_last_full_compute = full_compute_every_n_changes 81 | } 82 | ;; 83 | 84 | let full_compute { init; f; children; _ } = 85 | let result = ref init in 86 | for i = 0 to Array.length children - 1 do 87 | result := f !result (Uopt.value_exn (Array.unsafe_get children i).value_opt) 88 | done; 89 | !result 90 | ;; 91 | 92 | let compute t = 93 | if t.num_changes_since_last_full_compute = t.full_compute_every_n_changes 94 | then ( 95 | t.num_changes_since_last_full_compute <- 0; 96 | t.fold_value <- Uopt.some (full_compute t)); 97 | Uopt.value_exn t.fold_value 98 | ;; 99 | 100 | let force_full_compute t = 101 | t.fold_value <- Uopt.get_none (); 102 | t.num_changes_since_last_full_compute <- t.full_compute_every_n_changes 103 | ;; 104 | 105 | let child_changed 106 | (type a b) 107 | (t : (a, _) t) 108 | ~(child : b Node.t) 109 | ~child_index 110 | ~(old_value_opt : b Uopt.t) 111 | ~(new_value : b) 112 | = 113 | let child_at_index = t.children.(child_index) in 114 | match Node.type_equal_if_phys_same child child_at_index with 115 | | None -> 116 | raise_s 117 | [%message 118 | "[Unordered_array_fold.child_changed] mismatch" 119 | ~unordered_array_fold:(t : (_, _) t) 120 | (child_index : int) 121 | (child : _ Node.t)] 122 | | Some T -> 123 | if t.num_changes_since_last_full_compute < t.full_compute_every_n_changes - 1 124 | then ( 125 | t.num_changes_since_last_full_compute <- t.num_changes_since_last_full_compute + 1; 126 | (* We only reach this case if we have already done a full compute, in which case 127 | [Uopt.is_some t.fold_value] and [Uopt.is_some old_value_opt]. *) 128 | t.fold_value 129 | <- Uopt.some 130 | (t.update 131 | (Uopt.value_exn t.fold_value) 132 | ~old_value:(Uopt.value_exn old_value_opt) 133 | ~new_value)) 134 | else if t.num_changes_since_last_full_compute < t.full_compute_every_n_changes 135 | then force_full_compute t 136 | ;; 137 | -------------------------------------------------------------------------------- /src/node.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A [Node.t] is one node in the incremental DAG. The key invariants of a node [t] are: 4 | 5 | - if [is_necessary t], then [t.height > c.height], for all children [c] of [t]. 6 | - if [is_necessary t], then [t.height > Scope.height t.created_in]. 7 | - [is_necessary p] for all parents [p] of [t]. 8 | - [t.height < p.height] for all parents [p] of [t]. 9 | - [needs_to_be_computed t = is_in_recompute_heap t]. 10 | 11 | Outside of stabilization, when the recompute heap is empty, the invariant implies that 12 | if [is_necessary t], then [t.recomputed_at >= c.changed_at] for all children [c] of 13 | [t]. I.e. it implies that all necessary nodes aren't stale. *) 14 | 15 | open! Core 16 | open! Import 17 | 18 | (** For performance reasons, we do not use an OCaml existential type for [Node.Packed.t]: 19 | 20 | {[ 21 | type t = T : _ Node.t -> t 22 | ]} 23 | 24 | The extra indirection when following pointers to packed nodes would be too slow. 25 | 26 | Consequently, there is a possible bug in which we mix the ['a] from two packed nodes 27 | with different types. We reduce the chance of this bug by minimizing the scopes in 28 | which we deal with packed nodes. *) 29 | module Packed : sig 30 | type t = Types.Node.Packed.t = T : _ Types.Node.t -> t 31 | [@@unboxed] [@@deriving sexp_of] 32 | 33 | include Invariant.S with type t := t 34 | 35 | (** [As_list] allows one to view a node as a list w.r.t. a particular [next] pointer 36 | contained within it. The recompute heap uses this with [next_in_recompute_heap], and 37 | the adjust-heights heap uses this with [next_in_adjust_heights_heap]. *) 38 | module As_list (M : sig 39 | val next : t -> t Uopt.t 40 | end) : sig 41 | type t = Types.Node.Packed.t Uopt.t [@@deriving sexp_of] 42 | 43 | include Invariant.S with type t := t 44 | 45 | val length : t -> int 46 | val iter : t -> f:(Types.Node.Packed.t -> unit) -> unit 47 | end 48 | 49 | (** [iter_descendants ts ~f] calls [f] on every node in [ts] and all of their 50 | descendants exactly once per node. *) 51 | val iter_descendants : t list -> f:(t -> unit) -> unit 52 | 53 | val append_user_info_graphviz 54 | : t 55 | -> label:string list 56 | -> attrs:string String.Map.t 57 | -> unit 58 | end 59 | 60 | include module type of struct 61 | include Types.Node 62 | end 63 | with module Packed := Types.Node.Packed 64 | 65 | include Invariant.S1 with type 'a t := 'a t 66 | 67 | val create : Types.State.t -> Scope.t -> 'a Kind.t -> 'a t 68 | 69 | (** One should only set the kind of a node using [set_kind] -- using [t.kind <-] will 70 | violate invariants. *) 71 | val set_kind : 'a t -> 'a Kind.t -> unit 72 | 73 | val same : _ t -> _ t -> bool 74 | 75 | (** [iteri_children t ~f] applies [f] to all children of [t]. *) 76 | val iteri_children : _ t -> f:(int -> Packed.t -> unit) -> unit 77 | 78 | (*_ 79 | (** [iteri_parents t ~f] applies [f] to all necessary parents of [t]. *) 80 | val iteri_parents : _ t -> f:(int -> Packed.t -> unit) -> unit *) 81 | 82 | (** [get_parent t ~index] raises unless [0 <= index < t.num_parents]. *) 83 | val get_parent : _ t -> index:int -> Packed.t 84 | 85 | val add_parent : child:'a t -> parent:'b t -> child_index:int -> unit 86 | val remove_parent : child:'a t -> parent:'b t -> child_index:int -> unit 87 | 88 | val swap_children_except_in_kind 89 | : _ t 90 | -> child1:_ t 91 | -> child_index1:int 92 | -> child2:_ t 93 | -> child_index2:int 94 | -> unit 95 | 96 | val is_const : _ t -> bool 97 | val is_in_recompute_heap : _ t -> bool 98 | 99 | (** [is_necessary t] iff [t] is a descendant of an observer or [t] is a [Freeze] node. *) 100 | val is_necessary : _ t -> bool 101 | 102 | (** [is_valid t] returns [true] iff the left-hand-side of [t]'s defining bind hasn't 103 | changed since [t] was created. *) 104 | val is_valid : _ t -> bool 105 | 106 | (** [should_be_invalidated t] returns [true] iff [t] has an invalid child that implies 107 | that [t] should be invalid. It doesn't take into account [t.created_in]. *) 108 | val should_be_invalidated : _ t -> bool 109 | 110 | (** [edge_is_stale] returns [true] iff [child] has changed since [parent] was computed, 111 | and implies [is_stale parent]. [edge_is_stale] is constant-time. *) 112 | val edge_is_stale : child:_ t -> parent:_ t -> bool 113 | 114 | (** [is_stale t] is true if [t] has never been computed or if some child changed since [t] 115 | was last computed. [is_stale] doesn't take into account [t.created_in]. *) 116 | val is_stale : _ t -> bool 117 | 118 | (** [needs_to_be_computed] is [is_necessary t && is_stale t] *) 119 | val needs_to_be_computed : _ t -> bool 120 | 121 | (** Getting the value of a node. 122 | 123 | [value_exn t] raises iff [Uopt.is_none t.value_opt]. [unsafe_value t] is safe iff 124 | [Uopt.is_some t.value_opt]. *) 125 | val value_exn : 'a t -> 'a 126 | 127 | val unsafe_value : 'a t -> 'a 128 | val get_cutoff : 'a t -> 'a Cutoff.t 129 | val set_cutoff : 'a t -> 'a Cutoff.t -> unit 130 | 131 | (** [on_update t on_update_handler] adds an on-update handler to [t]. *) 132 | val on_update : 'a t -> 'a On_update_handler.t -> unit 133 | 134 | (** [run_on_update_handlers t node_update ~now] runs [t]'s on-update handlers, except 135 | those created at the stabilization [now]. *) 136 | val run_on_update_handlers 137 | : 'a t 138 | -> 'a On_update_handler.Node_update.t 139 | -> now:Stabilization_num.t 140 | -> unit 141 | 142 | val user_info : _ t -> Info.t option 143 | val set_user_info : _ t -> Info.t option -> unit 144 | 145 | val append_user_info_graphviz 146 | : _ t 147 | -> label:string list 148 | -> attrs:string String.Map.t 149 | -> unit 150 | 151 | (** These functions are meant for debug, as they are not very efficient. *) 152 | val has_child : _ t -> child:_ t -> bool 153 | 154 | val has_parent : _ t -> parent:_ t -> bool 155 | -------------------------------------------------------------------------------- /doc/part5-time.mdx: -------------------------------------------------------------------------------- 1 | # Incremental tutorial, Part 5; Time 2 | 3 | The goal of Incremental is to let you write code that looks a lot like 4 | a naive, all-at-once implementation, but that behaves more like a 5 | hand-tuned incremental version. But this can be a tricky thing to do, 6 | particularly for computations that depend on the current time in a 7 | serious way. 8 | 9 | Let's look at a concrete example: computing staleness. We'll assume 10 | we have a collection of services that are configured to start and stop 11 | at particular times, and we want to compute the set of servers that 12 | should be down, but are in fact still running. 13 | 14 | First, let's start by modeling out some types for this example. 15 | 16 | ```ocaml 17 | open Core 18 | module Time_ns = Time_ns_unix 19 | module Service_id : Identifiable = String 20 | module Service_status = struct 21 | type t = 22 | { id : Service_id.t 23 | ; start_time: Time_ns.t 24 | ; stop_time: Time_ns.t option 25 | ; is_running: bool 26 | } 27 | end 28 | ``` 29 | 30 | Now, let's try to write a function that computes the set of services 31 | that should have stopped, but that appear to be running nonetheless. 32 | Here's an all-at-once implementation: 33 | 34 | ```ocaml 35 | # let should_have_stopped services ~grace_period ~now = 36 | Map.filter services ~f:(fun (si:Service_status.t) -> 37 | match si.stop_time with 38 | | None -> false 39 | | Some stop_time -> 40 | let threshold = Time_ns.add stop_time grace_period in 41 | si.is_running && Time_ns.(>) now threshold) 42 | val should_have_stopped : 43 | ('a, Service_status.t, 'b) Map.t -> 44 | grace_period:Time_ns.Span.t -> 45 | now:Time_ns.t -> ('a, Service_status.t, 'b) Map.t = 46 | ``` 47 | 48 | Now, let's try to create an incremental version of this, where the map 49 | of service infos and the `now` are both passed in as incrementals. 50 | First, let's set up Incremental. 51 | 52 | ```ocaml 53 | module Incr = Incremental.Make () 54 | module Incr_map = Incr_map.Make(Incr) 55 | open Incr.Let_syntax 56 | ``` 57 | 58 | And now, we can define the incremental version. 59 | 60 | ```ocaml 61 | # let should_have_stopped services ~grace_period ~now = 62 | Incr_map.filter_mapi' services ~f:(fun ~key:_ ~data:(si:Service_status.t Incr.t) -> 63 | let%map si = si and now = now in 64 | match si.stop_time with 65 | | None -> None 66 | | Some stop_time -> 67 | let threshold = Time_ns.add stop_time grace_period in 68 | if si.is_running && Time_ns.(>) now threshold then Some si else None) 69 | val should_have_stopped : 70 | ('a, Service_status.t, 'b) Map.t Incr.t -> 71 | grace_period:Time_ns.Span.t -> 72 | now:Time_ns.t Incr.t -> ('a, Service_status.t, 'b) Map.t Incr.t = 73 | ``` 74 | 75 | This looks incremental, but it isn't, really. True, when the map of 76 | status changes, you only have to do work for the specific service 77 | statuses that have been updated. But when the time changes, every 78 | incremental in the map refires. And time changes a lot! 79 | 80 | Incremental's built-in support for time-based computations can help. 81 | To use it, we first need to get our hands on an Incremental clock, 82 | which is an imperative data structure that you can feed the current 83 | time to. 84 | 85 | ```ocaml 86 | # let clock = 87 | Incr.Clock.create () 88 | ~start:(Time_ns.of_string "2019-01-01 00:00:00") 89 | val clock : Incr.Clock.t = 90 | ``` 91 | 92 | You can ask a clock for an incremental that gives you the current 93 | time: 94 | 95 | ```ocaml 96 | # let now = Incr.Clock.watch_now clock 97 | val now : Time_ns.t Incr.t = 98 | ``` 99 | 100 | But that's hard to use efficiently, since `now` is always changing. A 101 | better thing to use is `Incr.Clock.at`, which creates an incremental 102 | whose value flips from `Before` to `After` when a particular threshold 103 | time is hit. Thus, you can write: 104 | 105 | ```ocaml 106 | # let before_or_after = 107 | Incr.observe 108 | (Incr.Clock.at clock (Time_ns.of_string "2019-01-01 11:00:00")) 109 | val before_or_after : Incr.Before_or_after.t Incr.Observer.t = 110 | ``` 111 | 112 | As you can see below, the value of this incremental starts out as 113 | `Before`: 114 | 115 | ```ocaml 116 | # let show () = 117 | Incr.stabilize (); 118 | print_s [%sexp (Incr.Observer.value_exn before_or_after : Incr.Before_or_after.t)];; 119 | val show : unit -> unit = 120 | # let () = show () 121 | Before 122 | ``` 123 | 124 | But if we advance the time, we'll see it change to `After`. 125 | 126 | ```ocaml 127 | # let () = 128 | Incr.Clock.advance_clock clock 129 | ~to_:(Time_ns.of_string "2019-01-01 11:00:01"); 130 | show () 131 | After 132 | ``` 133 | 134 | There's an efficient implementation of this under the covers. Instead 135 | of each `Incr.Clock.at` having to be updated every time the clock is 136 | advanced, we store the time at which the `Incr.Clock.at` needs to 137 | change in a `Timing_wheel.t`, which is an efficient, time-sorted 138 | queue. That way, updating each incremental returned by 139 | `Incr.Clock.at` is really inexpensive. 140 | 141 | Let's see how we can use `Incr.Clock.at` to make a more efficient 142 | implementation of `should_have_stopped`. 143 | 144 | ```ocaml 145 | # let should_have_stopped clock services ~grace_period = 146 | Incr_map.filter_mapi' services ~f:(fun ~key:_ ~data:(si:Service_status.t Incr.t) -> 147 | let%bind si = si in 148 | match si.is_running, si.stop_time with 149 | | false, _ | _, None -> return None 150 | | _, Some stop_time -> 151 | match%map Incr.Clock.at clock (Time_ns.add stop_time grace_period) with 152 | | Before -> None 153 | | After -> Some si) 154 | val should_have_stopped : 155 | Incr.Clock.t -> 156 | ('a, Service_status.t, 'b) Map.t Incr.t -> 157 | grace_period:Time_ns.Span.t -> ('a, Service_status.t, 'b) Map.t Incr.t = 158 | 159 | ``` 160 | 161 | Note the use of `bind` and `return` here. Despite our earlier 162 | exhortations to be careful about using these functions, these uses are 163 | reasonable because we're only doing a small amount of work on the 164 | right-hand side of the bind. 165 | 166 | 167 | And the overall computation has good incremental performance relative 168 | to time changes. In particular, the `Incr.Clock.at` nodes don't 169 | update every time the clock advances, but only when the clock crosses 170 | the appropriate time threshold. 171 | 172 | [Part 6: Patterns](./part6-patterns.mdx) 173 | -------------------------------------------------------------------------------- /src/internal_observer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open! Import 3 | open Types.Internal_observer 4 | 5 | module Packed_ = struct 6 | include Types.Internal_observer.Packed 7 | 8 | let sexp_of_t (T internal_observer) = 9 | internal_observer.observing |> [%sexp_of: _ Types.Node.t] 10 | ;; 11 | 12 | let prev_in_all (T t) = t.prev_in_all 13 | let next_in_all (T t) = t.next_in_all 14 | let set_prev_in_all (T t1) t2 = t1.prev_in_all <- t2 15 | let set_next_in_all (T t1) t2 = t1.next_in_all <- t2 16 | end 17 | 18 | module State = struct 19 | type t = Types.Internal_observer.State.t = 20 | | Created 21 | | In_use 22 | | Disallowed 23 | | Unlinked 24 | [@@deriving sexp_of] 25 | end 26 | 27 | type 'a t = 'a Types.Internal_observer.t = 28 | { (* State transitions: 29 | 30 | {v 31 | Created --> In_use --> Disallowed --> Unlinked 32 | | ^ 33 | \-------------------------------------/ 34 | v} *) 35 | mutable state : State.t 36 | ; observing : 'a Node.t 37 | ; mutable on_update_handlers : 'a On_update_handler.t list 38 | ; (* [{prev,next}_in_all] doubly link all observers in [state.all_observers]. *) 39 | mutable prev_in_all : Packed_.t Uopt.t 40 | ; mutable next_in_all : Packed_.t Uopt.t 41 | ; (* [{prev,next}_in_observing] doubly link all observers of [observing]. *) 42 | mutable prev_in_observing : ('a t[@sexp.opaque]) Uopt.t 43 | ; mutable next_in_observing : ('a t[@sexp.opaque]) Uopt.t 44 | } 45 | [@@deriving fields ~getters ~iterators:iter, sexp_of] 46 | 47 | type 'a internal_observer = 'a t [@@deriving sexp_of] 48 | 49 | let incr_state t = t.observing.state 50 | 51 | let use_is_allowed t = 52 | match t.state with 53 | | Created | In_use -> true 54 | | Disallowed | Unlinked -> false 55 | ;; 56 | 57 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 58 | let same_as_packed (t1 : _ t) (Packed_.T t2) = same t1 t2 59 | 60 | let invariant invariant_a t = 61 | Invariant.invariant t [%sexp_of: _ t] (fun () -> 62 | let check f = Invariant.check_field t f in 63 | Fields.iter 64 | ~state:ignore 65 | ~observing:(check (Node.invariant invariant_a)) 66 | ~on_update_handlers: 67 | (check (fun on_update_handlers -> 68 | match t.state with 69 | | Created | In_use | Disallowed -> () 70 | | Unlinked -> assert (List.is_empty on_update_handlers))) 71 | ~prev_in_all: 72 | (check (fun prev_in_all -> 73 | (match t.state with 74 | | In_use | Disallowed -> () 75 | | Created | Unlinked -> assert (Uopt.is_none prev_in_all)); 76 | if Uopt.is_some prev_in_all 77 | then 78 | assert ( 79 | same_as_packed 80 | t 81 | (Uopt.value_exn (Packed_.next_in_all (Uopt.value_exn prev_in_all)))))) 82 | ~next_in_all: 83 | (check (fun next_in_all -> 84 | (match t.state with 85 | | In_use | Disallowed -> () 86 | | Created | Unlinked -> assert (Uopt.is_none next_in_all)); 87 | if Uopt.is_some next_in_all 88 | then 89 | assert ( 90 | same_as_packed 91 | t 92 | (Uopt.value_exn (Packed_.prev_in_all (Uopt.value_exn next_in_all)))))) 93 | ~prev_in_observing: 94 | (check (fun prev_in_observing -> 95 | (match t.state with 96 | | In_use | Disallowed -> () 97 | | Created | Unlinked -> assert (Uopt.is_none prev_in_observing)); 98 | if Uopt.is_some prev_in_observing 99 | then 100 | assert ( 101 | phys_equal 102 | t 103 | (Uopt.value_exn (next_in_observing (Uopt.value_exn prev_in_observing)))))) 104 | ~next_in_observing: 105 | (check (fun next_in_observing -> 106 | (match t.state with 107 | | In_use | Disallowed -> () 108 | | Created | Unlinked -> assert (Uopt.is_none next_in_observing)); 109 | if Uopt.is_some next_in_observing 110 | then 111 | assert ( 112 | phys_equal 113 | t 114 | (Uopt.value_exn (prev_in_observing (Uopt.value_exn next_in_observing))))))) 115 | ;; 116 | 117 | let value_exn t = 118 | match t.state with 119 | | Created -> failwiths "Observer.value_exn called without stabilizing" t [%sexp_of: _ t] 120 | | Disallowed | Unlinked -> 121 | failwiths "Observer.value_exn called after disallow_future_use" t [%sexp_of: _ t] 122 | | In_use -> 123 | let uopt = t.observing.value_opt in 124 | if Uopt.is_none uopt 125 | then failwiths "attempt to get value of an invalid node" t [%sexp_of: _ t]; 126 | Uopt.unsafe_value uopt 127 | ;; 128 | 129 | let on_update_exn t on_update_handler = 130 | match t.state with 131 | | Disallowed | Unlinked -> failwiths "on_update disallowed" t [%sexp_of: _ t] 132 | | Created | In_use -> 133 | t.on_update_handlers <- on_update_handler :: t.on_update_handlers; 134 | (match t.state with 135 | | Disallowed | Unlinked -> assert false 136 | | Created -> 137 | (* We'll bump [observing.num_on_update_handlers] when [t] is actually added to 138 | [observing.observers] at the start of the next stabilization. *) 139 | () 140 | | In_use -> 141 | let observing = t.observing in 142 | observing.num_on_update_handlers <- observing.num_on_update_handlers + 1) 143 | ;; 144 | 145 | let unlink_from_observing t = 146 | let prev = t.prev_in_observing in 147 | let next = t.next_in_observing in 148 | t.prev_in_observing <- Uopt.get_none (); 149 | t.next_in_observing <- Uopt.get_none (); 150 | if Uopt.is_some next then (Uopt.unsafe_value next).prev_in_observing <- prev; 151 | if Uopt.is_some prev then (Uopt.unsafe_value prev).next_in_observing <- next; 152 | let observing = t.observing in 153 | if phys_equal t (Uopt.value_exn observing.observers) then observing.observers <- next; 154 | observing.num_on_update_handlers 155 | <- observing.num_on_update_handlers - List.length t.on_update_handlers; 156 | t.on_update_handlers <- [] 157 | ;; 158 | 159 | let unlink_from_all t = 160 | let prev = t.prev_in_all in 161 | let next = t.next_in_all in 162 | t.prev_in_all <- Uopt.get_none (); 163 | t.next_in_all <- Uopt.get_none (); 164 | if Uopt.is_some next then Packed_.set_prev_in_all (Uopt.unsafe_value next) prev; 165 | if Uopt.is_some prev then Packed_.set_next_in_all (Uopt.unsafe_value prev) next 166 | ;; 167 | 168 | let unlink t = 169 | unlink_from_observing t; 170 | unlink_from_all t 171 | ;; 172 | 173 | module Packed = struct 174 | include Packed_ 175 | 176 | let sexp_of_t (T internal_observer) = 177 | internal_observer |> [%sexp_of: _ internal_observer] 178 | ;; 179 | 180 | let invariant (T t) = invariant ignore t 181 | end 182 | -------------------------------------------------------------------------------- /src/recompute_heap.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | 4 | module As_recompute_list = Node.Packed.As_list (struct 5 | let next (Node.Packed.T node) = node.next_in_recompute_heap 6 | end) 7 | 8 | module Nodes_by_height = struct 9 | type t = As_recompute_list.t Uniform_array.t [@@deriving sexp_of] 10 | 11 | (* We display the smallest prefix of [nodes_by_height] that includes all nodes. *) 12 | let sexp_of_t t = 13 | let max_nonempty_index = ref (-1) in 14 | Uniform_array.iteri t ~f:(fun i l -> if Uopt.is_some l then max_nonempty_index := i); 15 | Uniform_array.sub t ~pos:0 ~len:(!max_nonempty_index + 1) |> [%sexp_of: t] 16 | ;; 17 | end 18 | 19 | type t = Types.Recompute_heap.t = 20 | { mutable length : int 21 | ; mutable height_lower_bound : int 22 | ; mutable nodes_by_height : Nodes_by_height.t 23 | } 24 | [@@deriving fields ~getters ~iterators:iter, sexp_of] 25 | 26 | let max_height_allowed t = Uniform_array.length t.nodes_by_height - 1 27 | let is_empty t = t.length = 0 28 | 29 | let invariant t = 30 | Invariant.invariant t [%sexp_of: t] (fun () -> 31 | let check f = Invariant.check_field t f in 32 | Fields.iter 33 | ~length: 34 | (check (fun length -> 35 | let actual_length = ref 0 in 36 | Uniform_array.iter t.nodes_by_height ~f:(fun node -> 37 | actual_length := !actual_length + As_recompute_list.length node); 38 | [%test_eq: int] length !actual_length)) 39 | ~height_lower_bound: 40 | (check (fun height_lower_bound -> 41 | assert (height_lower_bound >= 0); 42 | assert (height_lower_bound <= Uniform_array.length t.nodes_by_height); 43 | for height = 0 to height_lower_bound - 1 do 44 | assert (Uopt.is_none (Uniform_array.get t.nodes_by_height height)) 45 | done)) 46 | ~nodes_by_height: 47 | (check (fun nodes_by_height -> 48 | Uniform_array.iteri nodes_by_height ~f:(fun height node -> 49 | As_recompute_list.iter node ~f:(fun (T node) -> 50 | assert (node.height_in_recompute_heap = height); 51 | assert (Node.needs_to_be_computed node)))))) 52 | ;; 53 | 54 | let create_nodes_by_height ~max_height_allowed = 55 | Uniform_array.create ~len:(max_height_allowed + 1) (Uopt.get_none ()) 56 | ;; 57 | 58 | let set_max_height_allowed t max_height_allowed = 59 | if debug 60 | then 61 | for i = max_height_allowed + 1 to Uniform_array.length t.nodes_by_height - 1 do 62 | assert (Uopt.is_none (Uniform_array.get t.nodes_by_height i)) 63 | done; 64 | let src = t.nodes_by_height in 65 | let dst = create_nodes_by_height ~max_height_allowed in 66 | Uniform_array.blit 67 | ~src 68 | ~src_pos:0 69 | ~dst 70 | ~dst_pos:0 71 | ~len:(min (Uniform_array.length src) (Uniform_array.length dst)); 72 | t.nodes_by_height <- dst; 73 | t.height_lower_bound <- min t.height_lower_bound (Uniform_array.length dst) 74 | ;; 75 | 76 | let create ~max_height_allowed = 77 | { length = 0 78 | ; height_lower_bound = max_height_allowed + 1 79 | ; nodes_by_height = create_nodes_by_height ~max_height_allowed 80 | } 81 | ;; 82 | 83 | let set_next (prev : Node.Packed.t Uopt.t) ~next = 84 | if Uopt.is_some prev 85 | then ( 86 | let (T prev) = Uopt.unsafe_value prev in 87 | prev.next_in_recompute_heap <- next) 88 | ;; 89 | 90 | let set_prev (next : Node.Packed.t Uopt.t) ~prev = 91 | if Uopt.is_some next 92 | then ( 93 | let (T next) = Uopt.unsafe_value next in 94 | next.prev_in_recompute_heap <- prev) 95 | ;; 96 | 97 | let link (type a) t (node : a Node.t) = 98 | let height = node.height in 99 | if debug then assert (height <= max_height_allowed t); 100 | node.height_in_recompute_heap <- height; 101 | let next = Uniform_array.get t.nodes_by_height height in 102 | node.next_in_recompute_heap <- next; 103 | set_prev next ~prev:(Uopt.some (Node.Packed.T node)); 104 | Uniform_array.unsafe_set t.nodes_by_height height (Uopt.some (Node.Packed.T node)) 105 | ;; 106 | 107 | let unlink (type a) t (node : a Node.t) = 108 | let prev = node.prev_in_recompute_heap in 109 | let next = node.next_in_recompute_heap in 110 | if phys_same 111 | (Uopt.some node) 112 | (Uniform_array.get t.nodes_by_height node.height_in_recompute_heap) 113 | then Uniform_array.unsafe_set t.nodes_by_height node.height_in_recompute_heap next; 114 | set_prev next ~prev; 115 | set_next prev ~next; 116 | node.prev_in_recompute_heap <- Uopt.get_none () 117 | ;; 118 | 119 | (* We don't set [node.next_in_recompute_heap] here, but rather after calling [unlink]. *) 120 | 121 | let add (type a) t (node : a Node.t) = 122 | if debug && (Node.is_in_recompute_heap node || not (Node.needs_to_be_computed node)) 123 | then 124 | failwiths "incorrect attempt to add node to recompute heap" node [%sexp_of: _ Node.t]; 125 | if debug then assert (node.height <= max_height_allowed t); 126 | let height = node.height in 127 | if height < t.height_lower_bound then t.height_lower_bound <- height; 128 | link t node; 129 | t.length <- t.length + 1 130 | ;; 131 | 132 | let remove (type a) t (node : a Node.t) = 133 | if debug && ((not (Node.is_in_recompute_heap node)) || Node.needs_to_be_computed node) 134 | then 135 | failwiths "incorrect [remove] of node from recompute heap" node [%sexp_of: _ Node.t]; 136 | unlink t node; 137 | node.next_in_recompute_heap <- Uopt.get_none (); 138 | node.height_in_recompute_heap <- -1; 139 | t.length <- t.length - 1 140 | ;; 141 | 142 | let increase_height (type a) t (node : a Node.t) = 143 | if debug 144 | then ( 145 | assert (node.height > node.height_in_recompute_heap); 146 | assert (node.height <= max_height_allowed t); 147 | assert (Node.is_in_recompute_heap node)); 148 | unlink t node; 149 | link t node 150 | ;; 151 | 152 | let min_height t = 153 | if t.length = 0 154 | then t.height_lower_bound <- Uniform_array.length t.nodes_by_height 155 | else ( 156 | let nodes_by_height = t.nodes_by_height in 157 | while Uopt.is_none (Uniform_array.get nodes_by_height t.height_lower_bound) do 158 | t.height_lower_bound <- t.height_lower_bound + 1 159 | done); 160 | t.height_lower_bound 161 | ;; 162 | 163 | let remove_min t : Node.Packed.t = 164 | if debug then assert (not (is_empty t)); 165 | let nodes_by_height = t.nodes_by_height in 166 | let node = ref (Uniform_array.get nodes_by_height t.height_lower_bound) in 167 | while Uopt.is_none !node do 168 | t.height_lower_bound <- t.height_lower_bound + 1; 169 | if debug && t.height_lower_bound >= Uniform_array.length t.nodes_by_height 170 | then 171 | failwiths 172 | "Recompute_heap.remove_min unexpectedly reached end of heap" 173 | t 174 | [%sexp_of: t]; 175 | node := Uniform_array.get nodes_by_height t.height_lower_bound 176 | done; 177 | let (T node) = Uopt.unsafe_value !node in 178 | node.height_in_recompute_heap <- -1; 179 | t.length <- t.length - 1; 180 | let next = node.next_in_recompute_heap in 181 | Uniform_array.set t.nodes_by_height t.height_lower_bound next; 182 | set_prev next ~prev:(Uopt.get_none ()); 183 | if debug then assert (Uopt.is_none node.prev_in_recompute_heap); 184 | node.next_in_recompute_heap <- Uopt.get_none (); 185 | T node 186 | ;; 187 | -------------------------------------------------------------------------------- /src/expert.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | module Node = Types.Node 4 | 5 | type 'a edge = 'a Types.Expert.edge = 6 | { child : 'a Node.t 7 | ; on_change : 'a -> unit 8 | ; (* [index] is defined whenever the [edge] is in the [children] of some [t]. Then it is 9 | the index of this [edge] in that [children] array. It might seem redundant with all 10 | the other indexes we have, but it is necessary to remove children. The index may 11 | change as sibling children are removed. *) 12 | mutable index : int Uopt.t 13 | } 14 | [@@deriving sexp_of] 15 | 16 | type packed_edge = Types.Expert.packed_edge = E : 'a edge -> packed_edge 17 | [@@unboxed] [@@deriving sexp_of] 18 | 19 | type 'a t = 'a Types.Expert.t = 20 | { f : unit -> 'a 21 | ; on_observability_change : is_now_observable:bool -> unit 22 | ; mutable children : packed_edge Uopt.t Uniform_array.t 23 | ; mutable num_children : int 24 | ; (* When set, makes the node of [t] stale. It is set when the set of children changes. 25 | Otherwise the normal check of staleness (comparing the [changed_at] field of 26 | children and the [recomputed_at] field for the node of [t]) would not be enough. 27 | This plays a role similar to the cutoff of [Never] for the lhs-change of binds, but 28 | we don't have a special child. *) 29 | mutable force_stale : bool 30 | ; (* The number of invalid children that point to us. Used to determine whether the node 31 | of [t] needs to invalidated, without iterating over all the children. This is not 32 | needed for other nodes, because there are no other nodes that have a potentially 33 | large and dynamic set of children. *) 34 | mutable num_invalid_children : int 35 | ; (* Whether we will fire the [on_change] callbacks for all children when the node of [t] 36 | itself runs. Used to make sure we rerun everything after [t] switches from 37 | unobservable and back to observable. *) 38 | mutable will_fire_all_callbacks : bool 39 | } 40 | [@@deriving sexp_of] 41 | 42 | let invariant 43 | _invariant_a 44 | { f = _ 45 | ; children 46 | ; num_children 47 | ; force_stale = _ 48 | ; num_invalid_children 49 | ; on_observability_change = _ 50 | ; will_fire_all_callbacks = _ 51 | } 52 | = 53 | assert (num_children <= Uniform_array.length children); 54 | ignore num_invalid_children; 55 | (* invariant is below, because we need some context *) 56 | Uniform_array.iteri children ~f:(fun i uopt -> 57 | match i < num_children with 58 | | true -> 59 | let (E r) = Uopt.value_exn uopt in 60 | [%test_result: int] (Uopt.value_exn r.index) ~expect:i 61 | | false -> assert (Uopt.is_none uopt)) 62 | ;; 63 | 64 | let invariant_about_num_invalid_children t ~is_necessary = 65 | let { children; num_children; num_invalid_children; _ } = t in 66 | if not is_necessary 67 | then [%test_result: int] num_invalid_children ~expect:0 68 | else ( 69 | let count_invalid_children = ref 0 in 70 | for i = 0 to num_children - 1 do 71 | let (E r) = Uopt.value_exn (Uniform_array.get children i) in 72 | if not (Node.is_valid r.child) then incr count_invalid_children 73 | done; 74 | [%test_result: int] num_invalid_children ~expect:!count_invalid_children) 75 | ;; 76 | 77 | let create ~f ~on_observability_change = 78 | { f 79 | ; on_observability_change 80 | ; children = Uniform_array.get_empty () 81 | ; num_children = 0 82 | ; force_stale = false 83 | ; num_invalid_children = 0 84 | ; will_fire_all_callbacks = true 85 | } 86 | ;; 87 | 88 | let make_stale t = 89 | if t.force_stale 90 | then `Already_stale 91 | else ( 92 | t.force_stale <- true; 93 | `Ok) 94 | ;; 95 | 96 | let incr_invalid_children t = t.num_invalid_children <- t.num_invalid_children + 1 97 | let decr_invalid_children t = t.num_invalid_children <- t.num_invalid_children - 1 98 | 99 | let make_space_for_child_if_necessary t = 100 | if t.num_children >= Uniform_array.length t.children 101 | then ( 102 | if debug then assert (t.num_children = Uniform_array.length t.children); 103 | let new_max = Int.max 2 (2 * Uniform_array.length t.children) in 104 | t.children <- Uniform_array.realloc t.children ~len:new_max) 105 | ;; 106 | 107 | let add_child_edge t packed_edge = 108 | let (E edge) = packed_edge in 109 | assert (Uopt.is_none edge.index); 110 | make_space_for_child_if_necessary t; 111 | let new_child_index = t.num_children in 112 | edge.index <- Uopt.some new_child_index; 113 | Uniform_array.set t.children new_child_index (Uopt.some packed_edge); 114 | t.num_children <- t.num_children + 1; 115 | t.force_stale <- true; 116 | (* We will bump the number of invalid children if necessary when connecting child and 117 | parent. Same thing for running the [on_change] callbacks. *) 118 | new_child_index 119 | ;; 120 | 121 | let swap_children t ~child_index1 ~child_index2 = 122 | let (E edge1) = Uopt.value_exn (Uniform_array.get t.children child_index1) in 123 | let (E edge2) = Uopt.value_exn (Uniform_array.get t.children child_index2) in 124 | edge1.index <- Uopt.some child_index2; 125 | edge2.index <- Uopt.some child_index1; 126 | Uniform_array.swap t.children child_index1 child_index2 127 | ;; 128 | 129 | let last_child_edge_exn t = 130 | let last_index = t.num_children - 1 in 131 | Uopt.value_exn (Uniform_array.get t.children last_index) 132 | ;; 133 | 134 | let remove_last_child_edge_exn t = 135 | let last_index = t.num_children - 1 in 136 | let packed_edge_opt = Uniform_array.get t.children last_index in 137 | Uniform_array.set t.children last_index (Uopt.get_none ()); 138 | t.num_children <- last_index; 139 | t.force_stale <- true; 140 | assert (Uopt.is_some packed_edge_opt); 141 | let (E edge) = Uopt.unsafe_value packed_edge_opt in 142 | edge.index <- Uopt.none 143 | ;; 144 | 145 | let before_main_computation t = 146 | if t.num_invalid_children > 0 147 | then `Invalid 148 | else ( 149 | t.force_stale <- false; 150 | let will_fire_all_callbacks = t.will_fire_all_callbacks in 151 | t.will_fire_all_callbacks <- false; 152 | if will_fire_all_callbacks 153 | then 154 | for i = 0 to t.num_children - 1 do 155 | let (E r) = Uopt.value_exn (Uniform_array.get t.children i) in 156 | r.on_change (Uopt.value_exn r.child.value_opt) 157 | done; 158 | `Ok) 159 | ;; 160 | 161 | let observability_change t ~is_now_observable = 162 | t.on_observability_change ~is_now_observable; 163 | if not is_now_observable 164 | then ( 165 | t.will_fire_all_callbacks <- true; 166 | (* If we don't reset num_invalid_children, we would double count them: just imagine 167 | what happens we if reconnect/disconnect/reconnect/disconnect with an invalid 168 | child. *) 169 | t.num_invalid_children <- 0) 170 | ;; 171 | 172 | let run_edge_callback t ~child_index = 173 | if not t.will_fire_all_callbacks 174 | then ( 175 | let (E r) = Uopt.value_exn (Uniform_array.get t.children child_index) in 176 | (* This value is not necessarily set, because we try to run this when connecting the 177 | node to its children, which could be before they have run even once. Also the node 178 | could be invalid. *) 179 | if Uopt.is_some r.child.value_opt 180 | then r.on_change (Uopt.unsafe_value r.child.value_opt)) 181 | ;; 182 | -------------------------------------------------------------------------------- /doc/part2-dynamic.mdx: -------------------------------------------------------------------------------- 1 | # Incremental tutorial, Part 2; Dynamic computations with bind 2 | 3 | The computations we've contemplated thus far have been static, which 4 | is to say that the basic shape of the computation doesn't change. For 5 | example, our last example in the previous section was summing together 6 | a fixed set of inputs. The individual values could change, but not 7 | which inputs are included. 8 | 9 | Bind, it turns out, provides us with one simple mechanism for making 10 | computations more dynamic. To illustrate how it works, let's consider 11 | two different ways of expressing an if statement, one using `map`, one 12 | using `bind`. 13 | 14 | ```ocaml 15 | # open Core 16 | # module Incr = Incremental.Make () 17 | module Incr : Incremental.S 18 | # open Incr.Let_syntax;; 19 | 20 | # let if_with_map c t e = 21 | let%map c = c and t = t and e = e in 22 | if c then t else e 23 | val if_with_map : bool Incr.t -> 'a Incr.t -> 'a Incr.t -> 'a Incr.t = 24 | ``` 25 | 26 | This creates a computation graph that looks something like this. 27 | 28 | ``` 29 | +---+ 30 | | c |-. 31 | +---+ \ 32 | +---+ '->+----+ 33 | | t |----->| if | 34 | +---+ .->+----+ 35 | +---+ / 36 | | e |-' 37 | +---+ 38 | ``` 39 | 40 | In other words, the condition, then and else branch are all hooked up, 41 | and if any input changes, the if will be re-evaluated. But this 42 | really overapproximates the necessary dependencies, since, when the 43 | condition `c` is true, the `if` node should only depend on the `t`, 44 | not on the `e` node; and the reverse when `c` is false. In other 45 | words, the dependency structure should depend dynamically on the data. 46 | 47 | We can write that using `bind` as follows. 48 | 49 | ```ocaml 50 | # let if_with_bind c t e = 51 | let%bind c = c in 52 | if c then t else e 53 | val if_with_bind : bool Incr.t -> 'a Incr.t -> 'a Incr.t -> 'a Incr.t = 54 | ``` 55 | 56 | Here, we bind on `c`, and pick the corresponding incremental depending 57 | on the value of `c`. The dependency structure now will look like one 58 | of the following two pictures: 59 | 60 | ``` 61 | if c is true if c is false 62 | 63 | +---+ +---+ 64 | | c |-. | c |-. 65 | +---+ \ +---+ \ 66 | +---+ '->+----+ +---+ '->+----+ 67 | | t |----->| if | | t | | if | 68 | +---+ +----+ +---+ .->+----+ 69 | +---+ +---+ / 70 | | e | | e |-' 71 | +---+ +---+ 72 | ``` 73 | 74 | That's the very simplest form of dynamism, where the only thing that's 75 | changing dynamically is a single dependency. But `bind` lets you do more 76 | than just change dependencies; you can also create new computations 77 | with new nodes. 78 | 79 | Here's an example of this in action. First, let's bring back the 80 | function for summing together a list of incrementals from the previous 81 | part. 82 | 83 | ```ocaml 84 | # let incr_list_sum l = 85 | match List.reduce_balanced l ~f:(Incr.map2 ~f:( +. )) with 86 | | None -> return 0. 87 | | Some x -> x 88 | val incr_list_sum : float Incr.t list -> float Incr.t = 89 | ``` 90 | 91 | And let's get a starting set of input values. 92 | 93 | 94 | ```ocaml non-deterministic 95 | # let inputs = Array.init 10_000 ~f:(fun i -> Incr.Var.create (Float.of_int i));; 96 | val inputs : float Incr.Var.t array = 97 | [|; ; ; ...|] 98 | # let (:=) = Incr.Var.set 99 | val ( := ) : 'a Incr.Var.t -> 'a -> unit = 100 | # let (!) = Incr.Var.value;; 101 | val ( ! ) : 'a Incr.Var.t -> 'a = 102 | ``` 103 | 104 | Now, let's also create an incremental that dynamically chooses which 105 | values to sum together. Here, we'll initialize it to indices of the 106 | first 100 elements. 107 | 108 | ```ocaml 109 | # let things_to_sum = Incr.Var.create (List.init ~f:Fn.id 100) 110 | val things_to_sum : int list Incr.Var.t = 111 | ``` 112 | 113 | Now we can use `bind` to build a computation that sums together the 114 | elements from `inputs` as indicated by `things_to_sum`. 115 | 116 | ```ocaml 117 | # let dynamic_sum = 118 | let%bind things_to_sum = Incr.Var.watch things_to_sum in 119 | incr_list_sum 120 | (List.map things_to_sum ~f:(fun i -> 121 | Incr.Var.watch inputs.(i))) 122 | val dynamic_sum : float Incr.t = 123 | ``` 124 | 125 | Now, let's observe the value and write some code to stabilize the 126 | computation and print out the results. 127 | 128 | ```ocaml 129 | # let dynamic_sum_obs = Incr.observe dynamic_sum 130 | val dynamic_sum_obs : float Incr.Observer.t = 131 | # let print () = 132 | Incr.stabilize (); 133 | printf "%f\n" (Incr.Observer.value_exn dynamic_sum_obs);; 134 | val print : unit -> unit = 135 | # let () = print () 136 | 4950.000000 137 | ``` 138 | 139 | Now we can update the computation by either changing the values in the 140 | `inputs` array, or by changing `things_to_sum`. 141 | 142 | ```ocaml 143 | # let () = 144 | inputs.(3) := !(inputs.(3)) +. 50.; 145 | print () 146 | 5000.000000 147 | # let () = 148 | things_to_sum := [1;10;100]; 149 | print () 150 | 111.000000 151 | ``` 152 | 153 | # Incremental performance, and why you often want to avoid bind 154 | 155 | We've now used Incremental to build a computation that dynamically 156 | changes its structure. But let's stop for a moment to think about the 157 | performance characteristics of this version of the computation. After 158 | all, Incremental is an optimization framework! If you're not thinking 159 | about performance, you probably shouldn't be using Incremental at all. 160 | 161 | In particular, what is the *incremental performance* of `dynamic_sum`? 162 | I.e., what is the computational cost of stabilizing the computation 163 | after the inputs change? 164 | 165 | Generally speaking, the incremental performance of a computation 166 | depends on the nature of the change to its inputs. In this specific 167 | case, there are two simple cases worth thinking about: the cost of a 168 | change to the `inputs` array, and a change to `things_to_sum`. 169 | 170 | When the `inputs` array change, the cost is logarithmic in the size of 171 | the summation tree, i.e., logarithmic in the length of 172 | `things_to_sum`. 173 | 174 | When `things_to_sum` itself changes, however, you'll find the cost is 175 | quite a lot larger. Every time `things_to_sum` changes, the `bind` in 176 | the computation of `dynamic_sum` fires, and we have to rerun 177 | `incr_list_sum`. That means we have to rebuild the summation tree 178 | from scratch, the cost of which is linear in the length of 179 | `things_to_sum`. 180 | 181 | This highlights an important fact: *`bind` is often expensive*. In 182 | particular, if you make large parts of your graph dynamic by dint of 183 | using `bind`, you tend to make that part of the computation entirely 184 | non-incremental. A common anti-pattern people trip over when writing 185 | incremental code is to use `bind` in places where they should be using 186 | `map`, thereby destroying the incremental performance of their 187 | programs. (More on this later, in [Part 4: 188 | Pitfalls](./part4-pitfalls.mdx).) 189 | 190 | In the next part, we'll discuss other techniques for building dynamic, 191 | incremental computations. 192 | 193 | [Part 3: Incr\_map](./part3-map.mdx) 194 | -------------------------------------------------------------------------------- /src/adjust_heights_heap.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Import 3 | open Types.Kind 4 | 5 | module As_adjust_heights_list = Node.Packed.As_list (struct 6 | let next (Node.Packed.T node) = node.next_in_adjust_heights_heap 7 | end) 8 | 9 | module Nodes_by_height = struct 10 | type t = As_adjust_heights_list.t Uniform_array.t [@@deriving sexp_of] 11 | 12 | let sexp_of_t t = 13 | let max_nonempty_index = ref (-1) in 14 | Uniform_array.iteri t ~f:(fun i l -> if Uopt.is_some l then max_nonempty_index := i); 15 | Uniform_array.sub t ~pos:0 ~len:(!max_nonempty_index + 1) |> [%sexp_of: t] 16 | ;; 17 | 18 | let invariant t = 19 | Invariant.invariant t [%sexp_of: t] (fun () -> 20 | Uniform_array.iteri t ~f:(fun height nodes -> 21 | As_adjust_heights_list.invariant nodes; 22 | As_adjust_heights_list.iter nodes ~f:(fun (T node) -> 23 | assert (node.height_in_adjust_heights_heap = height); 24 | assert (node.height > node.height_in_adjust_heights_heap); 25 | if Node.is_in_recompute_heap node 26 | then assert (node.height_in_recompute_heap = node.height_in_adjust_heights_heap)))) 27 | ;; 28 | 29 | let create ~max_height_allowed = 30 | Uniform_array.create ~len:(max_height_allowed + 1) (Uopt.get_none ()) 31 | ;; 32 | 33 | let length t = 34 | let r = ref 0 in 35 | Uniform_array.iter t ~f:(fun node -> r := !r + As_adjust_heights_list.length node); 36 | !r 37 | ;; 38 | end 39 | 40 | type t = Types.Adjust_heights_heap.t = 41 | { mutable length : int 42 | ; mutable height_lower_bound : int 43 | ; mutable max_height_seen : int 44 | ; mutable nodes_by_height : Nodes_by_height.t 45 | } 46 | [@@deriving fields ~getters ~iterators:iter, sexp_of] 47 | 48 | let is_empty t = length t = 0 49 | let max_height_allowed t = Uniform_array.length t.nodes_by_height - 1 50 | 51 | let invariant t = 52 | Invariant.invariant t [%sexp_of: t] (fun () -> 53 | let check f = Invariant.check_field t f in 54 | Fields.iter 55 | ~length: 56 | (check (fun length -> assert (length = Nodes_by_height.length t.nodes_by_height))) 57 | ~height_lower_bound: 58 | (check (fun height_lower_bound -> 59 | assert (height_lower_bound >= 0); 60 | assert (height_lower_bound <= Uniform_array.length t.nodes_by_height); 61 | for height = 0 to height_lower_bound - 1 do 62 | assert (Uopt.is_none (Uniform_array.get t.nodes_by_height height)) 63 | done)) 64 | ~max_height_seen: 65 | (check (fun max_height_seen -> 66 | assert (max_height_seen >= 0); 67 | assert (max_height_seen <= max_height_allowed t))) 68 | ~nodes_by_height:(check Nodes_by_height.invariant)) 69 | ;; 70 | 71 | let create ~max_height_allowed = 72 | { length = 0 73 | ; height_lower_bound = max_height_allowed + 1 74 | ; max_height_seen = 0 75 | ; nodes_by_height = Nodes_by_height.create ~max_height_allowed 76 | } 77 | ;; 78 | 79 | let set_max_height_allowed t max_height_allowed = 80 | if max_height_allowed < t.max_height_seen 81 | then 82 | failwiths 83 | "cannot set_max_height_allowed less than the max height already seen" 84 | (max_height_allowed, `max_height_seen t.max_height_seen) 85 | [%sexp_of: int * [ `max_height_seen of int ]]; 86 | if debug then assert (is_empty t); 87 | t.nodes_by_height <- Nodes_by_height.create ~max_height_allowed 88 | ;; 89 | 90 | let add_unless_mem (type a) t (node : a Node.t) = 91 | if node.height_in_adjust_heights_heap = -1 92 | then ( 93 | let height = node.height in 94 | (* We process nodes in increasing order of pre-adjusted height, so it is a bug if we 95 | ever try to add a node that would violate that. *) 96 | if debug then assert (height >= t.height_lower_bound); 97 | (* Whenever we set a node's height, we use [set_height], which enforces this. *) 98 | if debug then assert (height <= max_height_allowed t); 99 | node.height_in_adjust_heights_heap <- height; 100 | t.length <- t.length + 1; 101 | node.next_in_adjust_heights_heap <- Uniform_array.get t.nodes_by_height height; 102 | Uniform_array.unsafe_set t.nodes_by_height height (Uopt.some (Node.Packed.T node))) 103 | ;; 104 | 105 | let remove_min_exn t : Node.Packed.t = 106 | if debug && is_empty t 107 | then failwiths "Adjust_heights_heap.remove_min of empty heap" t [%sexp_of: t]; 108 | let r = ref t.height_lower_bound in 109 | while Uopt.is_none (Uniform_array.get t.nodes_by_height !r) do 110 | incr r 111 | done; 112 | let height = !r in 113 | t.height_lower_bound <- height; 114 | let (T node) = Uopt.unsafe_value (Uniform_array.unsafe_get t.nodes_by_height height) in 115 | node.height_in_adjust_heights_heap <- -1; 116 | t.length <- t.length - 1; 117 | Uniform_array.unsafe_set t.nodes_by_height height node.next_in_adjust_heights_heap; 118 | node.next_in_adjust_heights_heap <- Uopt.get_none (); 119 | T node 120 | ;; 121 | 122 | let set_height t (node : _ Node.t) height = 123 | if height > t.max_height_seen 124 | then ( 125 | t.max_height_seen <- height; 126 | if height > max_height_allowed t 127 | then 128 | failwiths 129 | "node with too large height" 130 | (`Height height, `Max (max_height_allowed t)) 131 | [%sexp_of: [ `Height of int ] * [ `Max of int ]]); 132 | node.height <- height 133 | ;; 134 | 135 | let ensure_height_requirement t ~original_child ~original_parent ~child ~parent = 136 | if debug then assert (Node.is_necessary child); 137 | if debug then assert (Node.is_necessary parent); 138 | if Node.same parent original_child 139 | then 140 | failwiths 141 | "adding edge made graph cyclic" 142 | (`child original_child, `parent original_parent) 143 | [%sexp_of: [ `child of _ Node.t ] * [ `parent of _ Node.t ]]; 144 | if child.height >= parent.height 145 | then ( 146 | add_unless_mem t parent; 147 | (* We set [parent.height] after adding [parent] to the heap, so that [parent] goes 148 | in the heap with its pre-adjusted height. *) 149 | set_height t parent (child.height + 1)) 150 | ;; 151 | 152 | let adjust_heights 153 | (type a b) 154 | t 155 | recompute_heap 156 | ~child:(original_child : a Node.t) 157 | ~parent:(original_parent : b Node.t) 158 | = 159 | if debug then assert (is_empty t); 160 | if debug then assert (original_child.height >= original_parent.height); 161 | t.height_lower_bound <- original_parent.height; 162 | ensure_height_requirement 163 | t 164 | ~original_child 165 | ~original_parent 166 | ~child:original_child 167 | ~parent:original_parent; 168 | while length t > 0 do 169 | let (T child) = remove_min_exn t in 170 | if Node.is_in_recompute_heap child 171 | then Recompute_heap.increase_height recompute_heap child; 172 | if child.num_parents > 0 173 | then ( 174 | let (T parent) = Uopt.value_exn child.parent0 in 175 | ensure_height_requirement t ~original_child ~original_parent ~child ~parent; 176 | for parent_index = 1 to child.num_parents - 1 do 177 | let (T parent) = 178 | Uopt.value_exn (Uniform_array.get child.parent1_and_beyond (parent_index - 1)) 179 | in 180 | ensure_height_requirement t ~original_child ~original_parent ~child ~parent 181 | done); 182 | match child.kind with 183 | | Bind_lhs_change { all_nodes_created_on_rhs; _ } -> 184 | let r = ref all_nodes_created_on_rhs in 185 | while Uopt.is_some !r do 186 | let (T node_on_rhs) = Uopt.unsafe_value !r in 187 | r := node_on_rhs.next_node_in_same_scope; 188 | if Node.is_necessary node_on_rhs 189 | then 190 | ensure_height_requirement 191 | t 192 | ~original_child 193 | ~original_parent 194 | ~child 195 | ~parent:node_on_rhs 196 | done 197 | | _ -> () 198 | done; 199 | if debug then assert (is_empty t); 200 | if debug then assert (original_child.height < original_parent.height) 201 | ;; 202 | -------------------------------------------------------------------------------- /skeleton/skeleton.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | module Node_id = Incremental.For_analyzer.Node_id 3 | module Dot_user_info = Incremental.For_analyzer.Dot_user_info 4 | 5 | type t = 6 | { nodes : Node.t list 7 | ; seen : Node_id.Set.t 8 | ; num_stabilizes : int 9 | } 10 | [@@deriving sexp] 11 | 12 | module Render_target = struct 13 | type t = 14 | | Dot 15 | | Graph_easy 16 | end 17 | 18 | let normalize_ids skeleton = 19 | let nodes = skeleton.nodes in 20 | match nodes with 21 | | [] -> skeleton 22 | | hd :: _ as nodes -> 23 | let lowest_id = 24 | List.map nodes ~f:(fun node -> Node_id.to_int node.id) 25 | |> List.min_elt ~compare:Int.compare 26 | |> Option.value ~default:(Node_id.to_int hd.id) 27 | in 28 | let new_id node_id = 29 | (* Nodes are one-indexed *) 30 | Node_id.to_int node_id - lowest_id + 1 |> Node_id.of_int 31 | in 32 | let nodes = 33 | List.map nodes ~f:(fun node -> 34 | let id = new_id node.id in 35 | let children = List.map node.children ~f:new_id in 36 | let bind_children = List.map node.bind_children ~f:new_id in 37 | { node with id; children; bind_children }) 38 | in 39 | let seen = Node_id.Set.map skeleton.seen ~f:new_id in 40 | { skeleton with nodes; seen } 41 | ;; 42 | 43 | let snapshot ?(normalize = false) state = 44 | let seen = Node_id.Hash_set.create () in 45 | let nodes = ref Reversed_list.[] in 46 | let add_node 47 | ~id 48 | ~kind 49 | ~cutoff 50 | ~children 51 | ~bind_children 52 | ~user_info 53 | ~recomputed_at 54 | ~changed_at 55 | ~height 56 | = 57 | Hash_set.add seen id; 58 | let new_node = 59 | { Node.id 60 | ; kind 61 | ; cutoff 62 | ; children 63 | ; bind_children 64 | ; user_info 65 | ; recomputed_at 66 | ; changed_at 67 | ; height 68 | } 69 | in 70 | nodes := new_node :: !nodes 71 | in 72 | Incremental.For_analyzer.traverse 73 | (Incremental.For_analyzer.directly_observed state) 74 | ~add_node; 75 | let skeleton = 76 | { nodes = Reversed_list.rev !nodes 77 | ; seen = Node_id.Set.of_hash_set seen 78 | ; num_stabilizes = Incremental.State.num_stabilizes state 79 | } 80 | in 81 | if normalize then normalize_ids skeleton else skeleton 82 | ;; 83 | 84 | let node_name (node_id : Node_id.t) = "n" ^ Node_id.to_string node_id 85 | 86 | let make_node ~(node : Node.t) ~extra_attrs ~(render_target : Render_target.t) = 87 | let name = node_name node.id in 88 | let base_node_dot = 89 | Dot_user_info.dot 90 | ~label: 91 | [ name 92 | ; Sexp.to_string ([%sexp_of: Incremental.For_analyzer.Kind.t] node.kind) 93 | ; sprintf "height=%d" node.height 94 | ] 95 | ~attributes: 96 | (match render_target with 97 | | Dot -> String.Map.singleton "fontname" "Sans Serif" 98 | | Graph_easy -> String.Map.empty) 99 | in 100 | let info = 101 | let node_info = 102 | Option.value_map node.user_info ~default:base_node_dot ~f:(fun user_info -> 103 | Dot_user_info.append base_node_dot user_info) 104 | in 105 | let attrs_opt = extra_attrs node in 106 | Option.value_map attrs_opt ~default:node_info ~f:(fun attrs -> 107 | Dot_user_info.append node_info attrs) 108 | in 109 | Text_block.text 110 | (Dot_user_info.to_string 111 | ?shape: 112 | (match render_target with 113 | | Dot -> None 114 | | Graph_easy -> Some "box") 115 | ~name 116 | (Dot_user_info.to_dot info)) 117 | ;; 118 | 119 | (* The parameters' names reflect the ordering of these nodes in the [Incr] graph where 120 | the children of a node are the inputs (e.g. a Var would be the child of a Map), but it 121 | seems more intuitive to visualize it in the opposite direction*) 122 | let edge ~from ~to_ = Text_block.textf {|%s -> %s|} (node_name to_) (node_name from) 123 | 124 | let make_edges ~(nodes : Node.t list) ~desired_nodes = 125 | List.concat_map nodes ~f:(fun from_node -> 126 | let from_node_id = from_node.id in 127 | List.filter_map from_node.children ~f:(fun to_node_id -> 128 | Option.some_if 129 | (Set.mem desired_nodes to_node_id) 130 | (edge ~from:from_node_id ~to_:to_node_id))) 131 | ;; 132 | 133 | let bind_edge ~from ~to_ = 134 | Text_block.textf {|%s -> %s [style=dashed]|} (node_name to_) (node_name from) 135 | ;; 136 | 137 | (* Note that the direction of information flow is flipped in bind nodes as compared to 138 | regular child nodes *) 139 | let make_bind_edges ~(nodes : Node.t list) ~desired_nodes ~seen = 140 | List.concat_map nodes ~f:(fun to_node -> 141 | let to_node_id = to_node.id in 142 | List.filter_map to_node.bind_children ~f:(fun from_node_id -> 143 | Option.some_if 144 | (Set.mem desired_nodes from_node_id && Set.mem seen from_node_id) 145 | (bind_edge ~from:from_node_id ~to_:to_node_id))) 146 | ;; 147 | 148 | let find_connected_nodes 149 | ~(start_nodes : Node_id.t list) 150 | ~(edges : Node_id.t list Node_id.Map.t) 151 | = 152 | let rec recurse_node node_id seen = 153 | if Set.mem seen node_id 154 | then seen 155 | else ( 156 | let seen = Set.add seen node_id in 157 | let node_ids = Map.find_multi edges node_id in 158 | List.fold node_ids ~init:seen ~f:(fun seen child_id -> recurse_node child_id seen)) 159 | in 160 | List.fold start_nodes ~init:Node_id.Set.empty ~f:(fun seen node_id -> 161 | recurse_node node_id seen) 162 | ;; 163 | 164 | let to_dot 165 | ?(extra_attrs = fun _ -> None) 166 | ?(render_target = Render_target.Dot) 167 | ?(filtered_nodes : Node.t list = []) 168 | ?(render_relation = Render_relation.All) 169 | { nodes; seen; num_stabilizes = _ } 170 | = 171 | let desired_nodes = 172 | let child_edges = 173 | lazy 174 | (List.fold nodes ~init:Node_id.Map.empty ~f:(fun child_edges node -> 175 | let added_bind = 176 | List.fold node.bind_children ~init:child_edges ~f:(fun edges bind_id -> 177 | Map.add_multi edges ~key:bind_id ~data:node.id) 178 | in 179 | List.fold node.children ~init:added_bind ~f:(fun edges child_id -> 180 | Map.add_multi edges ~key:node.id ~data:child_id))) 181 | in 182 | let parent_edges = 183 | lazy 184 | (Map.fold 185 | (force child_edges) 186 | ~init:Node_id.Map.empty 187 | ~f:(fun ~key:node_id ~data:children parent_edges -> 188 | List.fold children ~init:parent_edges ~f:(fun parent_edges child_id -> 189 | Map.add_multi parent_edges ~key:child_id ~data:node_id))) 190 | in 191 | let find_connected_nodes = 192 | find_connected_nodes ~start_nodes:(List.map filtered_nodes ~f:(fun node -> node.id)) 193 | in 194 | match render_relation with 195 | | Ancestors -> find_connected_nodes ~edges:(force child_edges) 196 | | Descendants -> find_connected_nodes ~edges:(force parent_edges) 197 | | Both -> 198 | Set.union 199 | (find_connected_nodes ~edges:(force parent_edges)) 200 | (find_connected_nodes ~edges:(force child_edges)) 201 | | All -> Node_id.Set.of_list (List.map nodes ~f:(fun node -> node.id)) 202 | in 203 | let desired_node_list = 204 | List.filter nodes ~f:(fun node -> Set.mem desired_nodes node.id) 205 | in 206 | let edges = make_edges ~nodes:desired_node_list ~desired_nodes in 207 | let bind_edges = make_bind_edges ~nodes:desired_node_list ~desired_nodes ~seen in 208 | let nodes = 209 | List.map desired_node_list ~f:(fun node -> 210 | make_node ~node ~extra_attrs ~render_target) 211 | in 212 | let text_block = 213 | let open Text_block in 214 | vcat 215 | [ text "digraph G {" 216 | ; indent 217 | (vcat 218 | (text "rankdir = TB" 219 | :: text "bgcolor = transparent" 220 | :: (nodes @ edges @ bind_edges))) 221 | ; text "}" 222 | ] 223 | in 224 | Text_block.render text_block 225 | ;; 226 | -------------------------------------------------------------------------------- /test/test_for_analyzer.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Import 3 | open Incremental.For_analyzer 4 | 5 | type node_print = 6 | { id : Node_id.t 7 | ; kind : Kind.t 8 | ; cutoff : Cutoff.t 9 | ; children : Node_id.t list 10 | ; bind_children : Node_id.t list 11 | ; recomputed_at : Stabilization_num.t 12 | ; changed_at : Stabilization_num.t 13 | ; height : int 14 | } 15 | [@@deriving sexp_of] 16 | 17 | let print_nodes node_list pack output_node = 18 | let nodes = ref [] in 19 | traverse 20 | (List.map node_list ~f:pack) 21 | ~add_node: 22 | (fun 23 | ~id 24 | ~kind 25 | ~cutoff 26 | ~children 27 | ~bind_children 28 | ~user_info:_ 29 | ~recomputed_at 30 | ~changed_at 31 | ~height 32 | -> 33 | nodes 34 | := { id; kind; cutoff; children; bind_children; recomputed_at; changed_at; height } 35 | :: !nodes); 36 | let min_id_opt = 37 | List.map !nodes ~f:(fun node -> Node_id.to_string node.id |> int_of_string) 38 | |> List.min_elt ~compare:Int.compare 39 | in 40 | match min_id_opt with 41 | | None -> () 42 | | Some min_id -> 43 | let new_id node_id = 44 | let id_num = (Node_id.to_string node_id |> int_of_string) - min_id + 1 in 45 | Node_id.t_of_sexp [%sexp (id_num : int)] 46 | in 47 | List.iter !nodes ~f:(fun node -> 48 | let node = 49 | let new_children = List.map node.children ~f:new_id in 50 | let new_bind_children = List.map node.bind_children ~f:new_id in 51 | { node with 52 | id = new_id node.id 53 | ; children = new_children 54 | ; bind_children = new_bind_children 55 | } 56 | in 57 | output_node node) 58 | ;; 59 | 60 | let print_node node = print_s [%message (node : node_print)] 61 | 62 | let print_computation_info node = 63 | let id = node.id in 64 | let recomputed_at = node.recomputed_at in 65 | let changed_at = node.changed_at in 66 | print_s 67 | [%message 68 | (id : Node_id.t) 69 | (recomputed_at : Stabilization_num.t) 70 | (changed_at : Stabilization_num.t)] 71 | ;; 72 | 73 | let%expect_test "traverses basic" = 74 | let module Incr = Incremental.Make () in 75 | let n = Incr.return "hello" in 76 | print_nodes [ n ] Incr.pack print_node; 77 | [%expect 78 | {| 79 | (node ( 80 | (id 1) 81 | (kind Const) 82 | (cutoff Phys_equal) 83 | (children ()) 84 | (bind_children ()) 85 | (recomputed_at -1) 86 | (changed_at -1) 87 | (height -1))) 88 | |}] 89 | ;; 90 | 91 | let%expect_test "traverses map" = 92 | let module Incr = Incremental.Make () in 93 | let n = Incr.return "hello" in 94 | let r = Incr.map n ~f:(fun s -> s ^ "!") in 95 | print_nodes [ r ] Incr.pack print_node; 96 | [%expect 97 | {| 98 | (node ( 99 | (id 1) 100 | (kind Const) 101 | (cutoff Phys_equal) 102 | (children ()) 103 | (bind_children ()) 104 | (recomputed_at -1) 105 | (changed_at -1) 106 | (height -1))) 107 | (node ( 108 | (id 2) 109 | (kind Map) 110 | (cutoff Phys_equal) 111 | (children (1)) 112 | (bind_children ()) 113 | (recomputed_at -1) 114 | (changed_at -1) 115 | (height -1))) 116 | |}] 117 | ;; 118 | 119 | let%expect_test "traverses bind" = 120 | let module Incr = Incremental.Make () in 121 | let x = Incr.Var.create 1 in 122 | let a = Incr.return 3 in 123 | let b = Incr.return 4 in 124 | let cond = Incr.map (Incr.Var.watch x) ~f:(fun i -> i % 2 = 0) in 125 | let c = 126 | Incr.bind cond ~f:(fun bool -> if bool then a else Incr.map b ~f:(fun i -> i * 4)) 127 | in 128 | print_nodes [ c ] Incr.pack print_node; 129 | [%expect 130 | {| 131 | (node ( 132 | (id 1) 133 | (kind Var) 134 | (cutoff Phys_equal) 135 | (children ()) 136 | (bind_children ()) 137 | (recomputed_at -1) 138 | (changed_at -1) 139 | (height -1))) 140 | (node ( 141 | (id 4) 142 | (kind Map) 143 | (cutoff Phys_equal) 144 | (children (1)) 145 | (bind_children ()) 146 | (recomputed_at -1) 147 | (changed_at -1) 148 | (height -1))) 149 | (node ( 150 | (id 5) 151 | (kind Bind_lhs_change) 152 | (cutoff Never) 153 | (children (4)) 154 | (bind_children ()) 155 | (recomputed_at -1) 156 | (changed_at -1) 157 | (height -1))) 158 | (node ( 159 | (id 6) 160 | (kind Bind_main) 161 | (cutoff Phys_equal) 162 | (children (5)) 163 | (bind_children ()) 164 | (recomputed_at -1) 165 | (changed_at -1) 166 | (height -1))) 167 | |}]; 168 | let observer_so_that_stabilization_performs_work = Incr.observe c in 169 | Incr.stabilize (); 170 | let (_ : _ Incr.Observer.t) = 171 | Sys.opaque_identity observer_so_that_stabilization_performs_work 172 | in 173 | print_nodes [ c ] Incr.pack print_node; 174 | [%expect 175 | {| 176 | (node ( 177 | (id 3) 178 | (kind Const) 179 | (cutoff Phys_equal) 180 | (children ()) 181 | (bind_children ()) 182 | (recomputed_at 0) 183 | (changed_at 0) 184 | (height 0))) 185 | (node ( 186 | (id 7) 187 | (kind Map) 188 | (cutoff Phys_equal) 189 | (children (3)) 190 | (bind_children ()) 191 | (recomputed_at 0) 192 | (changed_at 0) 193 | (height 3))) 194 | (node ( 195 | (id 1) 196 | (kind Var) 197 | (cutoff Phys_equal) 198 | (children ()) 199 | (bind_children ()) 200 | (recomputed_at 0) 201 | (changed_at 0) 202 | (height 0))) 203 | (node ( 204 | (id 4) 205 | (kind Map) 206 | (cutoff Phys_equal) 207 | (children (1)) 208 | (bind_children ()) 209 | (recomputed_at 0) 210 | (changed_at 0) 211 | (height 1))) 212 | (node ( 213 | (id 5) 214 | (kind Bind_lhs_change) 215 | (cutoff Never) 216 | (children (4)) 217 | (bind_children (7)) 218 | (recomputed_at 0) 219 | (changed_at 0) 220 | (height 2))) 221 | (node ( 222 | (id 6) 223 | (kind Bind_main) 224 | (cutoff Phys_equal) 225 | (children (5 7)) 226 | (bind_children ()) 227 | (recomputed_at 0) 228 | (changed_at 0) 229 | (height 4))) 230 | |}] 231 | ;; 232 | 233 | let%expect_test "different recomputed_at and changed_at" = 234 | let module Incr = Incremental.Make () in 235 | let a = Incr.Var.create 3 in 236 | let a_val = Incr.Var.watch a in 237 | let mult = Incr.map a_val ~f:(fun a -> a % 2) in 238 | let mult_observer = Incr.observe mult in 239 | Incr.stabilize (); 240 | print_nodes [ mult ] Incr.pack print_computation_info; 241 | [%expect 242 | {| 243 | ((id 1) 244 | (recomputed_at 0) 245 | (changed_at 0)) 246 | ((id 2) 247 | (recomputed_at 0) 248 | (changed_at 0)) 249 | |}]; 250 | Incr.Var.set a 1; 251 | Incr.stabilize (); 252 | (* NOTE: The reason that [recomputed_at] and [changed_at] are different here, is that - 253 | according to the doc comments of incremental: 254 | 255 | - [recomputed_at] is the last stabilization when [t]'s value was recomputed, even if 256 | it was cut off. 257 | - [changed_at] is the last stabilization when this node was computed and not cut off. 258 | It is used to detect when [t]'s parents are stale and (because all parents are 259 | necessary) need to be recomputed. 260 | 261 | The modulo node was "recomputed" (3 % 2) and (1 % 2), but it did not "change" as the resulting 262 | value was the "same" according to its phys_equal cutoff. *) 263 | let (_ : _ Incr.Observer.t) = Sys.opaque_identity mult_observer in 264 | print_nodes [ mult ] Incr.pack print_computation_info; 265 | [%expect 266 | {| 267 | ((id 1) 268 | (recomputed_at 1) 269 | (changed_at 1)) 270 | ((id 2) 271 | (recomputed_at 1) 272 | (changed_at 0)) 273 | |}] 274 | ;; 275 | 276 | let%expect_test "directly observes all observers" = 277 | let module Incr = Incremental.Make () in 278 | let a = Incr.return "hello" in 279 | let b = Incr.map a ~f:(fun s -> s ^ "!") in 280 | let a' = Incr.return "world" in 281 | let b' = Incr.map a' ~f:(fun s -> s ^ ".") in 282 | let b_observer = Incr.observe b in 283 | let b'_observer = Incr.observe b' in 284 | print_nodes (directly_observed Incr.State.t) Fn.id print_node; 285 | [%expect {| |}]; 286 | Incr.stabilize (); 287 | let (_ : _ Incr.Observer.t) = Sys.opaque_identity b_observer in 288 | let (_ : _ Incr.Observer.t) = Sys.opaque_identity b'_observer in 289 | print_nodes (directly_observed Incr.State.t) Fn.id print_node; 290 | [%expect 291 | {| 292 | (node ( 293 | (id 1) 294 | (kind Const) 295 | (cutoff Phys_equal) 296 | (children ()) 297 | (bind_children ()) 298 | (recomputed_at 0) 299 | (changed_at 0) 300 | (height 0))) 301 | (node ( 302 | (id 2) 303 | (kind Map) 304 | (cutoff Phys_equal) 305 | (children (1)) 306 | (bind_children ()) 307 | (recomputed_at 0) 308 | (changed_at 0) 309 | (height 1))) 310 | (node ( 311 | (id 3) 312 | (kind Const) 313 | (cutoff Phys_equal) 314 | (children ()) 315 | (bind_children ()) 316 | (recomputed_at 0) 317 | (changed_at 0) 318 | (height 0))) 319 | (node ( 320 | (id 4) 321 | (kind Map) 322 | (cutoff Phys_equal) 323 | (children (3)) 324 | (bind_children ()) 325 | (recomputed_at 0) 326 | (changed_at 0) 327 | (height 1))) 328 | |}] 329 | ;; 330 | -------------------------------------------------------------------------------- /doc/part6-patterns.mdx: -------------------------------------------------------------------------------- 1 | # Incremental tutorial, Part 6; Patterns 2 | 3 | As we've already seen, using Incremental with pattern matching can 4 | have some unexpected consequences. For example, if you use record 5 | patterns to deconstruct a given value, you might end up with more 6 | dependencies than you expected. Here's an example demonstrating this 7 | from [part 1](./part1-preliminaries.mdx). 8 | 9 | ```ocaml 10 | open Core 11 | module Time_ns = Time_ns_unix 12 | module Unix = Core_unix 13 | module Incr = Incremental.Make () 14 | module Incr_map = Incr_map.Make (Incr);; 15 | open Incr.Let_syntax;; 16 | 17 | type z = 18 | { a: int list 19 | ; b: (int * int) 20 | } 21 | [@@deriving fields ~getters] 22 | ``` 23 | 24 | ```ocaml 25 | # let sumproduct z = 26 | let a_prod = 27 | let%map { a; _ } = z in 28 | List.fold ~init:1 ~f:( * ) a 29 | in 30 | let b_prod = 31 | let%map {b = (b1,b2); _ } = z in 32 | b1 * b2 33 | in 34 | let%map a_prod = a_prod and b_prod = b_prod in 35 | a_prod + b_prod 36 | val sumproduct : z Incr.t -> int Incr.t = 37 | ``` 38 | 39 | In the above code, it looks like the computation of `a_prod` and 40 | `b_prod` are independent, and so modifying just `a` should only cause 41 | `a_prod` to be recomputed, and modifying just `b` should only cause 42 | `b_prod` to be recomputed. 43 | 44 | But in reality, both computations depend on `z`, which means that 45 | whenever `z` changes, they'll both be rerun. 46 | 47 | We can make this better by introducing an intermediate incremental 48 | that includes just the value that `a_prod` requires (i.e., `a`), and 49 | having `a_prod` depend just on that (and similarly for `b_prod` and 50 | `b`). Here's what that code looks like: 51 | 52 | ```ocaml 53 | # let sumproduct z = 54 | let a_prod = 55 | let%map a = z >>| a in 56 | List.fold ~init:1 ~f:( * ) a 57 | in 58 | let b_prod = 59 | let%map (b1,b2) = z >>| b in 60 | b1 * b2 61 | in 62 | let%map a_prod = a_prod and b_prod = b_prod in 63 | a_prod + b_prod 64 | val sumproduct : z Incr.t -> int Incr.t = 65 | ``` 66 | 67 | This is a common enough idiom that it's useful to have some direct 68 | support for it in the case of pattern matching. We have that support 69 | in the form of a syntax extension called `ppx_pattern_bind`. Using 70 | `ppx_pattern_bind`, we can write: 71 | 72 | ```ocaml 73 | # let sumproduct z = 74 | let a_prod = 75 | let%pattern_map { a; _ } = z in 76 | List.fold ~init:1 ~f:( * ) a 77 | in 78 | let b_prod = 79 | let%pattern_map {b = (b1,b2); _ } = z in 80 | b1 * b2 81 | in 82 | let%map a_prod = a_prod and b_prod = b_prod in 83 | a_prod + b_prod 84 | val sumproduct : z Incr.t -> int Incr.t = 85 | ``` 86 | 87 | Now, the dependencies are as they should be, with `a_prod` only firing 88 | when `a` changes, and `b_prod` only firing when `b1` or `b2` changes. 89 | That's because `%pattern_map` automatically constructs the necessary 90 | projection function to extract the variables in question from the 91 | pattern, and then adds the appropriate intermediate incrementals based 92 | on those projection functions. 93 | 94 | This is pretty convenient when it comes to product types, like tuples 95 | and records; but it really shines when you start dealing with sum 96 | types, e.g., variants. 97 | 98 | Consider the following somewhat contrived example. Imagine that we 99 | have a text-based UI that can be in one of two different states; 100 | either it's showing a set of hosts, or its showing a collection of 101 | services, and in either case, we want to generate a textual 102 | representation of the subset of those services that are in a failed 103 | state. 104 | 105 | First, let's put together some types. 106 | 107 | ```ocaml 108 | # module Status = struct 109 | type t = | Healthy 110 | | Failed of { as_of : Time_ns.t } 111 | end 112 | module Status : sig type t = Healthy | Failed of { as_of : Time_ns.t; } end 113 | # module Hostname : Identifiable = String 114 | module Hostname : Core.Identifiable 115 | # module Host = struct 116 | type t = { addr: Unix.Inet_addr.t 117 | ; status : Status.t 118 | } 119 | end 120 | module Host : 121 | sig type t = { addr : Unix/2.inet_addr; status : Status.t; } end 122 | # module Service = struct 123 | module Id : Identifiable = String 124 | type t = { host : Hostname.t 125 | ; status : Status.t 126 | } 127 | end 128 | module Service : 129 | sig 130 | module Id : Core.Identifiable 131 | type t = { host : Hostname.t; status : Status.t; } 132 | end 133 | # module Model = struct 134 | type t = | Host_view of Host.t Map.M(Hostname).t 135 | | Service_view of Service.t Map.M(Service.Id).t 136 | end 137 | module Model : 138 | sig 139 | type t = 140 | Host_view of Host.t Core.Map.M(Hostname).t 141 | | Service_view of Service.t Core.Map.M(Service.Id).t 142 | end 143 | ``` 144 | 145 | Now, let's write out some plausible looking incremental code for 146 | generating the view of failed hosts or services. First, let's write 147 | incremental view functions that handle the host view and service view 148 | separately. 149 | 150 | ```ocaml 151 | # let view_failed (type a) (module M : Stringable with type t = a) get_status map = 152 | let failed = 153 | Incr_map.filter_mapi map ~f:(fun ~key:_ ~data -> 154 | match (get_status data : Status.t) with 155 | | Healthy -> None 156 | | Failed _ -> Some data) 157 | in 158 | let%map failed = failed in 159 | Map.keys failed 160 | |> List.map ~f:M.to_string 161 | |> String.concat ~sep:"\n" 162 | val view_failed : 163 | (module Core.Stringable with type t = 'a) -> 164 | ('b -> Status.t) -> ('a, 'b, 'c) Map.t Incr.t -> string Incr.t = 165 | # let view_failed_hosts hosts = 166 | view_failed (module Hostname) (fun (host:Host.t) -> host.status) hosts 167 | val view_failed_hosts : 168 | (Hostname.t, Host.t, 'a) Map.t Incr.t -> string Incr.t = 169 | # let view_failed_services services = 170 | view_failed (module Service.Id) (fun (service:Service.t) -> service.status) services 171 | val view_failed_services : 172 | (Service.Id.t, Service.t, 'a) Map.t Incr.t -> string Incr.t = 173 | ``` 174 | 175 | Now, the question comes of how we weave them together. Here's a first attempt. 176 | 177 | ```ocaml 178 | # let view (model : Model.t Incr.t) = 179 | match%map model with 180 | | Host_view hosts -> view_failed_hosts hosts 181 | | Service_view services -> view_failed_services services 182 | Line 3, characters 44-49: 183 | Error: This expression has type 184 | Host.t Core.Map.M(Hostname).t = 185 | (Hostname.t, Host.t, Hostname.comparator_witness) Map.t 186 | but an expression was expected of type 187 | (Hostname.t, Host.t, 'a) Map.t Incr.t = 188 | ((Hostname.t, Host.t, 'a) Map.t, Incr.state_witness) Incremental.t 189 | ``` 190 | 191 | But this doesn't type-check, because once we do the pattern match, we 192 | no longer have an incremental value to feed to `view_failed_hosts` and 193 | `view_failed_services`. In particular, now `hosts` and `services` are 194 | ordinary, non-incremental values. Even if we try to fix this by 195 | using `return` to convert those values into incremental, it still 196 | doesn't do the right thing. 197 | 198 | ```ocaml 199 | # let view (model : Model.t Incr.t) = 200 | match%map model with 201 | | Host_view hosts -> view_failed_hosts (return hosts) 202 | | Service_view services -> view_failed_services (return services) 203 | val view : Model.t Incr.t -> string Incr.t Incr.t = 204 | ``` 205 | 206 | In particular, it has the wrong return type, having an extra level of 207 | incrementality. We can fix this by using bind instead of map. 208 | 209 | ```ocaml 210 | # let view (model : Model.t Incr.t) = 211 | match%bind model with 212 | | Host_view hosts -> view_failed_hosts (return hosts) 213 | | Service_view services -> view_failed_services (return services) 214 | val view : Model.t Incr.t -> string Incr.t = 215 | ``` 216 | 217 | But while this has the right type, it has the entirely wrong 218 | incremental performance. In particular, every time the model changes, 219 | the entire computation is redone from scratch. That's the case even 220 | if the actual change is very small; say, a single entry added into the 221 | `hosts` view. 222 | 223 | Happily, `ppx_pattern_bind` can help us here as well. We can rewrite 224 | the above example as follows. 225 | 226 | ```ocaml 227 | # let view (model : Model.t Incr.t) = 228 | match%pattern_bind model with 229 | | Host_view hosts -> view_failed_hosts hosts 230 | | Service_view services -> view_failed_services services 231 | val view : Model.t Incr.t -> string Incr.t = 232 | ``` 233 | 234 | Note that the variables `hosts` and `services` that were bound as 235 | ordinary variables on the left-hand side of the arrow are treated as 236 | incremental variables on the right hand side. 237 | 238 | And now, the incremental performance is good. The idea here is that 239 | the full computation is only rerun in when we switch between cases 240 | (e.g., from `Host_view` to `Service_view`), but when we stay within 241 | the same case of the pattern match, we are effectively mapping over an 242 | incremental of the data contained therein. 243 | 244 | To get a better sense of how this actually works, let's think about 245 | what the above example actually desugars into. It's something like 246 | the following. 247 | 248 | ```ocaml 249 | # type model_kind = Host_view | Service_view;; 250 | type model_kind = Host_view | Service_view 251 | # let view (model : Model.t Incr.t) = 252 | let model_kind : model_kind Incr.t = 253 | match%map model with 254 | | Host_view _ -> Host_view 255 | | Service_view _ -> Service_view 256 | in 257 | match%bind model_kind with 258 | | Host_view -> 259 | let hosts = 260 | match%map model with 261 | | Host_view x -> x 262 | | Service_view _ -> assert false 263 | in 264 | view_failed_hosts hosts 265 | | Service_view -> 266 | let services = 267 | match%map model with 268 | | Service_view x -> x 269 | | Host_view _ -> assert false 270 | in 271 | view_failed_services services 272 | val view : Model.t Incr.t -> string Incr.t = 273 | ``` 274 | 275 | This makes the performance behavior a little more explicit. The code 276 | is effectively binding on the constructor tag alone first, and then 277 | doing a map over the data thus obtained. 278 | 279 | 280 | [Part 7: Performance and optimization](./part7-optimization.mdx) 281 | -------------------------------------------------------------------------------- /test/test_skeleton.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let%expect_test "render dot file" = 4 | let module Incr = Incremental.Make () in 5 | let open Incr.Let_syntax in 6 | let n1 = Incr.const 1 in 7 | let n2 = Incr.const 2 in 8 | let res = 9 | let%bind n1 in 10 | if n1 % 2 = 0 11 | then ( 12 | let%map n2 in 13 | n1 * n2) 14 | else n2 15 | in 16 | let observer = Incr.observe res in 17 | Incr.stabilize (); 18 | let result = Incr.Observer.value_exn observer in 19 | print_s [%message (result : int)]; 20 | [%expect {| (result 2) |}]; 21 | let skeleton = Incremental_skeleton.snapshot ~normalize:true Incr.State.t in 22 | print_s [%message (skeleton : Incremental_skeleton.t)]; 23 | [%expect 24 | {| 25 | (skeleton 26 | ((nodes 27 | (((id 4) (kind Bind_main) (children (3 2)) (recomputed_at 0) 28 | (changed_at 0) (height 2)) 29 | ((id 3) (kind Bind_lhs_change) (children (1)) (recomputed_at 0) 30 | (cutoff Never) (changed_at 0) (height 1)) 31 | ((id 1) (kind Const) (recomputed_at 0) (changed_at 0) (height 0)) 32 | ((id 2) (kind Const) (recomputed_at 0) (changed_at 0) (height 0)))) 33 | (seen (1 2 3 4)) (num_stabilizes 1))) 34 | |}]; 35 | let dot = Incremental_skeleton.to_dot ~render_target:Dot skeleton in 36 | let grapheasy_dot = Incremental_skeleton.to_dot ~render_target:Graph_easy skeleton in 37 | Expect_test_patdiff.print_patdiff dot grapheasy_dot; 38 | [%expect 39 | {| 40 | === DIFF HUNK === 41 | digraph G { 42 | rankdir = TB 43 | bgcolor = transparent 44 | -| n4 [shape=Mrecord label="{{n4|Bind_main|height=2}}" "fontname"="Sans Serif"] 45 | +| n4 [shape=box label="{{n4|Bind_main|height=2}}" ] 46 | -| n3 [shape=Mrecord label="{{n3|Bind_lhs_change|height=1}}" "fontname"="Sans Serif"] 47 | +| n3 [shape=box label="{{n3|Bind_lhs_change|height=1}}" ] 48 | -| n1 [shape=Mrecord label="{{n1|Const|height=0}}" "fontname"="Sans Serif"] 49 | +| n1 [shape=box label="{{n1|Const|height=0}}" ] 50 | -| n2 [shape=Mrecord label="{{n2|Const|height=0}}" "fontname"="Sans Serif"] 51 | +| n2 [shape=box label="{{n2|Const|height=0}}" ] 52 | n3 -> n4 53 | n2 -> n4 54 | n1 -> n3 55 | } 56 | |}] 57 | ;; 58 | 59 | let%expect_test "no binds" = 60 | let module Incr = Incremental.Make () in 61 | let node = Incr.return "hello" in 62 | let node = Incr.map node ~f:(fun x -> x ^ "!") in 63 | let result = Incr.observe node in 64 | Incr.stabilize (); 65 | let result = Incr.Observer.value_exn result in 66 | print_s [%message (result : string)]; 67 | [%expect {| (result hello!) |}]; 68 | let skeleton = Incremental_skeleton.snapshot ~normalize:true Incr.State.t in 69 | print_s [%message (skeleton : Incremental_skeleton.t)]; 70 | [%expect 71 | {| 72 | (skeleton 73 | ((nodes 74 | (((id 2) (kind Map) (children (1)) (recomputed_at 0) (changed_at 0) 75 | (height 1)) 76 | ((id 1) (kind Const) (recomputed_at 0) (changed_at 0) (height 0)))) 77 | (seen (1 2)) (num_stabilizes 1))) 78 | |}]; 79 | let dot = Incremental_skeleton.to_dot ~render_target:Graph_easy skeleton in 80 | print_endline dot; 81 | [%expect 82 | {| 83 | digraph G { 84 | rankdir = TB 85 | bgcolor = transparent 86 | n2 [shape=box label="{{n2|Map|height=1}}" ] 87 | n1 [shape=box label="{{n1|Const|height=0}}" ] 88 | n1 -> n2 89 | } 90 | |}]; 91 | Expect_test_graphviz.print_dot_blocking dot; 92 | [%expect 93 | {| 94 | ┌───────────────────────┐ 95 | │ {{n1|Const|height=0}} │ 96 | └───────────────────────┘ 97 | │ 98 | │ 99 | ▼ 100 | ┌───────────────────────┐ 101 | │ {{n2|Map|height=1}} │ 102 | └───────────────────────┘ 103 | |}] 104 | ;; 105 | 106 | let%expect_test "with binds" = 107 | let module Incr = Incremental.Make () in 108 | let open Incr.Let_syntax in 109 | let mk_incr i = 110 | let v = Incr.Var.create i in 111 | Incr.Var.watch v, v 112 | in 113 | let a, ai = mk_incr 0 in 114 | let b, _bi = mk_incr 3 in 115 | let c, _ci = mk_incr 4 in 116 | let node = 117 | let is_even = 118 | let%map a in 119 | a % 2 = 0 120 | in 121 | let%bind is_even in 122 | if is_even 123 | then return 0 124 | else ( 125 | let%map b and c in 126 | b * c) 127 | in 128 | let observer = Incr.observe node in 129 | Incr.stabilize (); 130 | let result = Incr.Observer.value_exn observer in 131 | print_s [%message (result : int)]; 132 | [%expect {| (result 0) |}]; 133 | let skeleton = Incremental_skeleton.snapshot ~normalize:true Incr.State.t in 134 | print_s [%message (skeleton : Incremental_skeleton.t)]; 135 | [%expect 136 | {| 137 | (skeleton 138 | ((nodes 139 | (((id 6) (kind Bind_main) (children (5 7)) (recomputed_at 0) 140 | (changed_at 0) (height 4)) 141 | ((id 5) (kind Bind_lhs_change) (children (4)) (bind_children (7)) 142 | (recomputed_at 0) (cutoff Never) (changed_at 0) (height 2)) 143 | ((id 4) (kind Map) (children (1)) (recomputed_at 0) (changed_at 0) 144 | (height 1)) 145 | ((id 1) (kind Var) (recomputed_at 0) (changed_at 0) (height 0)) 146 | ((id 7) (kind Const) (recomputed_at 0) (changed_at 0) (height 3)))) 147 | (seen (1 4 5 6 7)) (num_stabilizes 1))) 148 | |}]; 149 | Incr.Var.set ai 3; 150 | Incr.stabilize (); 151 | let result = Incr.Observer.value_exn observer in 152 | print_s [%message (result : int)]; 153 | [%expect {| (result 12) |}]; 154 | let new_skeleton = Incremental_skeleton.snapshot ~normalize:true Incr.State.t in 155 | Expect_test_sexp_diff.print_sexp_diff 156 | ([%sexp_of: Incremental_skeleton.t] skeleton) 157 | ([%sexp_of: Incremental_skeleton.t] new_skeleton); 158 | [%expect 159 | {| 160 | ((nodes ((nodes 161 | (((id 6) (((id 6) 162 | (kind Bind_main) (kind Bind_main) 163 | (children (children 164 | (5 (5 165 | - 7 + 9 166 | )) )) 167 | (recomputed_at (recomputed_at 168 | - 0 + 1 169 | ) ) 170 | (changed_at (changed_at 171 | - 0 + 1 172 | ) ) 173 | (height (height 174 | - 4 + 5 175 | )) )) 176 | ((id 5) ((id 5) 177 | (kind Bind_lhs_change) (kind Bind_lhs_change) 178 | (children (4)) (children (4)) 179 | (bind_children (bind_children 180 | - (7) + (9 8) 181 | ) ) 182 | (recomputed_at (recomputed_at 183 | - 0 + 1 184 | ) ) 185 | (cutoff Never) (cutoff Never) 186 | (changed_at (changed_at 187 | - 0 + 1 188 | ) ) 189 | (height 2)) (height 2)) 190 | ((id 4) ((id 4) 191 | (kind Map) (kind Map) 192 | (children (1)) (children (1)) 193 | (recomputed_at (recomputed_at 194 | - 0 + 1 195 | ) ) 196 | (changed_at (changed_at 197 | - 0 + 1 198 | ) ) 199 | (height 1)) (height 1)) 200 | ((id 1) ((id 1) 201 | (kind Var) (kind Var) 202 | (recomputed_at (recomputed_at 203 | - 0 + 1 204 | ) ) 205 | (changed_at (changed_at 206 | - 0 + 1 207 | ) ) 208 | (height 0)) (height 0)) 209 | + ((id 9) (kind Map) (children (8)) (recomputed_at 1) (changed_at 1) 210 | + (height 4)) 211 | ((id ((id 212 | - 7 + 8 213 | ) ) 214 | (kind (kind 215 | - Const + Map2 216 | ) ) 217 | + (children (2 3)) 218 | (recomputed_at (recomputed_at 219 | - 0 + 1 220 | ) ) 221 | (changed_at (changed_at 222 | - 0 + 1 223 | ) ) 224 | (height 3)) (height 3)) 225 | + ((id 2) (kind Var) (recomputed_at 1) (changed_at 1) (height 0)) 226 | + ((id 3) (kind Var) (recomputed_at 1) (changed_at 1) (height 0)) 227 | )) )) 228 | (seen (seen 229 | (1 (1 230 | + 2 231 | + 3 232 | 4 4 233 | 5 5 234 | 6 6 235 | + 8 236 | - 7 + 9 237 | )) )) 238 | (num_stabilizes (num_stabilizes 239 | - 1 + 2 240 | )) )) 241 | |}]; 242 | let dot = Incremental_skeleton.to_dot ~render_target:Graph_easy skeleton in 243 | print_endline dot; 244 | [%expect 245 | {| 246 | digraph G { 247 | rankdir = TB 248 | bgcolor = transparent 249 | n6 [shape=box label="{{n6|Bind_main|height=4}}" ] 250 | n5 [shape=box label="{{n5|Bind_lhs_change|height=2}}" ] 251 | n4 [shape=box label="{{n4|Map|height=1}}" ] 252 | n1 [shape=box label="{{n1|Var|height=0}}" ] 253 | n7 [shape=box label="{{n7|Const|height=3}}" ] 254 | n5 -> n6 255 | n7 -> n6 256 | n4 -> n5 257 | n1 -> n4 258 | n5 -> n7 [style=dashed] 259 | } 260 | |}]; 261 | Expect_test_graphviz.print_dot_blocking dot; 262 | [%expect 263 | {| 264 | ┌─────────────────────────────────┐ 265 | │ {{n1|Var|height=0}} │ 266 | └─────────────────────────────────┘ 267 | │ 268 | │ 269 | ▼ 270 | ┌─────────────────────────────────┐ 271 | │ {{n4|Map|height=1}} │ 272 | └─────────────────────────────────┘ 273 | │ 274 | │ 275 | ▼ 276 | ┌─────────────────────────────────┐ 277 | │ {{n5|Bind_lhs_change|height=2}} │ ─┐ 278 | └─────────────────────────────────┘ │ 279 | ╵ │ 280 | ╵ │ 281 | ▼ │ 282 | ┌─────────────────────────────────┐ │ 283 | │ {{n7|Const|height=3}} │ │ 284 | └─────────────────────────────────┘ │ 285 | │ │ 286 | │ │ 287 | ▼ │ 288 | ┌─────────────────────────────────┐ │ 289 | │ {{n6|Bind_main|height=4}} │ ◀┘ 290 | └─────────────────────────────────┘ 291 | |}] 292 | ;; 293 | 294 | let%expect_test "unobserved incr graph" = 295 | let module Incr = Incremental.Make () in 296 | let node = Incr.return "hello" in 297 | let node = Incr.map node ~f:(fun x -> x ^ "!") in 298 | let result = Incr.observe node in 299 | Incr.stabilize (); 300 | let skeleton = Incremental_skeleton.snapshot ~normalize:true Incr.State.t in 301 | print_s [%message (skeleton : Incremental_skeleton.t)]; 302 | [%expect 303 | {| 304 | (skeleton 305 | ((nodes 306 | (((id 2) (kind Map) (children (1)) (recomputed_at 0) (changed_at 0) 307 | (height 1)) 308 | ((id 1) (kind Const) (recomputed_at 0) (changed_at 0) (height 0)))) 309 | (seen (1 2)) (num_stabilizes 1))) 310 | |}]; 311 | Incr.Observer.disallow_future_use result; 312 | Incr.stabilize (); 313 | let skeleton = Incremental_skeleton.snapshot ~normalize:true Incr.State.t in 314 | print_s [%message (skeleton : Incremental_skeleton.t)]; 315 | [%expect {| (skeleton ((nodes ()) (seen ()) (num_stabilizes 2))) |}] 316 | ;; 317 | --------------------------------------------------------------------------------