├── .gitignore ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── debug_lib ├── debug.mlh ├── generate_debug_lib.sh └── jbuild ├── incremental_kernel.opam ├── src ├── adjust_heights_heap.ml ├── adjust_heights_heap.mli ├── alarm.ml ├── alarm.mli ├── alarm_value.ml ├── alarm_value.mli ├── array_fold.ml ├── array_fold.mli ├── at.ml ├── at.mli ├── at_intervals.ml ├── at_intervals.mli ├── balanced_reducer.ml ├── balanced_reducer.mli ├── before_or_after.ml ├── before_or_after.mli ├── bind.ml ├── bind.mli ├── config.ml ├── config.mli ├── config_intf.ml ├── cutoff.ml ├── cutoff.mli ├── debug.mlh ├── expert.ml ├── expert.mli ├── expert1.ml ├── expert1.mli ├── freeze.ml ├── freeze.mli ├── if_then_else.ml ├── if_then_else.mli ├── import.ml ├── incremental_kernel.ml ├── incremental_kernel.mli ├── incremental_kernel_intf.ml ├── internal_observer.ml ├── internal_observer.mli ├── jbuild ├── join.ml ├── join.mli ├── kind.ml ├── kind.mli ├── node.ml ├── node.mli ├── node_id.ml ├── node_id.mli ├── observer.ml ├── observer.mli ├── on_update_handler.ml ├── on_update_handler.mli ├── raised_exn.ml ├── raised_exn.mli ├── recompute_heap.ml ├── recompute_heap.mli ├── reduce_balanced.ml ├── reduce_balanced.mli ├── scope.ml ├── scope.mli ├── sexp_of.ml ├── should_not_use.ml ├── should_not_use.mli ├── snapshot.ml ├── snapshot.mli ├── stabilization_num.ml ├── stabilization_num.mli ├── state.ml ├── step_function.ml ├── step_function.mli ├── types.ml ├── unordered_array_fold.ml ├── unordered_array_fold.mli ├── var.ml └── var.mli └── test ├── import.ml ├── jbuild ├── test_balanced_reducer.ml ├── test_balanced_reducer.mli ├── test_config.ml ├── test_config.mli ├── test_deprecation.mlt ├── test_let_syntax.ml └── test_let_syntax.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | 5 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 113.43.00 2 | 3 | - Adds a `Let_syntax` module to `Incremental_intf.S`. I've found things like this 4 | useful in a couple of different projects as a nice alternative to the `mapN` 5 | functions. 6 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2016--2018 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | # Default rule 4 | default: 5 | jbuilder build @install 6 | 7 | install: 8 | jbuilder install $(INSTALL_ARGS) 9 | 10 | uninstall: 11 | jbuilder uninstall $(INSTALL_ARGS) 12 | 13 | reinstall: uninstall install 14 | 15 | clean: 16 | rm -rf _build 17 | 18 | .PHONY: default install uninstall reinstall clean 19 | -------------------------------------------------------------------------------- /debug_lib/debug.mlh: -------------------------------------------------------------------------------- 1 | [%%define JSC_DEBUG true] 2 | -------------------------------------------------------------------------------- /debug_lib/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_kernel*) 10 | target=$(echo $b | sed -r 's/incremental_kernel/incremental_kernel_debug/') 11 | rm -f $target 12 | sed <$b.tmp >$target -r 's/Incremental_kernel/Incremental_kernel_debug/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 | 23 | -------------------------------------------------------------------------------- /debug_lib/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name incremental_kernel_debug) 3 | (libraries (core_kernel 4 | core_kernel.uopt)) 5 | (preprocessor_deps (debug.mlh)) 6 | (preprocess (pps (ppx_jane ppxlib.runner))))) 7 | 8 | (rule 9 | ((targets ( 10 | ;; This is a list of all OCaml files from [../src], with [incremental_kernel*] replaced 11 | ;; by [incremental_kernel_debug*]. 12 | adjust_heights_heap.ml 13 | adjust_heights_heap.mli 14 | alarm.ml 15 | alarm.mli 16 | alarm_value.ml 17 | alarm_value.mli 18 | array_fold.ml 19 | array_fold.mli 20 | at_intervals.ml 21 | at_intervals.mli 22 | at.ml 23 | at.mli 24 | balanced_reducer.ml 25 | balanced_reducer.mli 26 | before_or_after.ml 27 | before_or_after.mli 28 | bind.ml 29 | bind.mli 30 | config_intf.ml 31 | config.ml 32 | config.mli 33 | cutoff.ml 34 | cutoff.mli 35 | expert1.ml 36 | expert1.mli 37 | expert.ml 38 | expert.mli 39 | freeze.ml 40 | freeze.mli 41 | if_then_else.ml 42 | if_then_else.mli 43 | import.ml 44 | incremental_kernel_debug_intf.ml 45 | incremental_kernel_debug.ml 46 | incremental_kernel_debug.mli 47 | internal_observer.ml 48 | internal_observer.mli 49 | join.ml 50 | join.mli 51 | kind.ml 52 | kind.mli 53 | node_id.ml 54 | node_id.mli 55 | node.ml 56 | node.mli 57 | observer.ml 58 | observer.mli 59 | on_update_handler.ml 60 | on_update_handler.mli 61 | raised_exn.ml 62 | raised_exn.mli 63 | recompute_heap.ml 64 | recompute_heap.mli 65 | reduce_balanced.ml 66 | reduce_balanced.mli 67 | scope.ml 68 | scope.mli 69 | sexp_of.ml 70 | should_not_use.ml 71 | should_not_use.mli 72 | snapshot.ml 73 | snapshot.mli 74 | stabilization_num.ml 75 | stabilization_num.mli 76 | state.ml 77 | step_function.ml 78 | step_function.mli 79 | types.ml 80 | unordered_array_fold.ml 81 | unordered_array_fold.mli 82 | var.ml 83 | var.mli 84 | )) 85 | (deps ( 86 | (glob_files ../src/*.ml) 87 | (glob_files ../src/*.mli) 88 | ./generate_debug_lib.sh)) 89 | (action (bash "./generate_debug_lib.sh")))) 90 | 91 | 92 | (jbuild_version 1) 93 | -------------------------------------------------------------------------------- /incremental_kernel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "opensource@janestreet.com" 3 | authors: ["Jane Street Group, LLC "] 4 | homepage: "https://github.com/janestreet/incremental_kernel" 5 | bug-reports: "https://github.com/janestreet/incremental_kernel/issues" 6 | dev-repo: "git+https://github.com/janestreet/incremental_kernel.git" 7 | license: "MIT" 8 | build: [ 9 | ["jbuilder" "build" "-p" name "-j" jobs] 10 | ] 11 | depends: [ 12 | "core_kernel" 13 | "ppx_jane" 14 | "jbuilder" {build & >= "1.0+beta18.1"} 15 | "ocaml-migrate-parsetree" {>= "1.0"} 16 | "ppxlib" {>= "0.1.0"} 17 | ] 18 | available: [ ocaml-version >= "4.06.1" ] 19 | descr: " 20 | Library for incremental computations depending only on Core_kernel 21 | 22 | Part of Jane Street's Core library 23 | The Core suite of libraries is an industrial strength alternative to 24 | OCaml's standard library that was developed by Jane Street, the 25 | largest industrial user of OCaml. 26 | " 27 | -------------------------------------------------------------------------------- /src/adjust_heights_heap.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | open Types.Kind 4 | 5 | module As_adjust_heights_list = 6 | Node.Packed.As_list (struct 7 | let next (node : _ Node.t) = node.next_in_adjust_heights_heap 8 | end) 9 | 10 | module Nodes_by_height = struct 11 | type t = As_adjust_heights_list.t Array.t [@@deriving sexp_of] 12 | 13 | let sexp_of_t t = 14 | let max_nonempty_index = ref (-1) in 15 | Array.iteri t ~f:(fun i l -> if Uopt.is_some l then max_nonempty_index := i); 16 | Array.sub t ~pos:0 ~len:(!max_nonempty_index + 1) |> [%sexp_of: t] 17 | ;; 18 | 19 | let invariant t = 20 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 21 | Array.iteri t ~f:(fun height nodes -> 22 | As_adjust_heights_list.invariant nodes; 23 | As_adjust_heights_list.iter nodes ~f:(fun node -> 24 | assert (node.height_in_adjust_heights_heap = height); 25 | assert (node.height > node.height_in_adjust_heights_heap); 26 | if Node.is_in_recompute_heap node 27 | then assert (node.height_in_recompute_heap 28 | = node.height_in_adjust_heights_heap)))) 29 | ;; 30 | 31 | let create ~max_height_allowed = 32 | Array.create ~len:(max_height_allowed + 1) Uopt.none 33 | ;; 34 | 35 | let length t = 36 | let r = ref 0 in 37 | Array.iter t ~f:(fun node -> r := !r + As_adjust_heights_list.length node); 38 | !r 39 | ;; 40 | end 41 | 42 | type t = 43 | { mutable length : int 44 | ; mutable height_lower_bound : int 45 | ; mutable max_height_seen : int 46 | ; mutable nodes_by_height : Nodes_by_height.t 47 | } 48 | [@@deriving fields, sexp_of] 49 | 50 | let is_empty t = length t = 0 51 | 52 | let max_height_allowed t = Array.length t.nodes_by_height - 1 53 | 54 | let invariant t = 55 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 56 | let check f = Invariant.check_field t f in 57 | Fields.iter 58 | ~length:(check (fun length -> 59 | assert (length = Nodes_by_height.length t.nodes_by_height))) 60 | ~height_lower_bound:(check (fun height_lower_bound -> 61 | assert (height_lower_bound >= 0); 62 | assert (height_lower_bound <= Array.length t.nodes_by_height); 63 | for height = 0 to height_lower_bound - 1 do 64 | assert (Uopt.is_none t.nodes_by_height.( height )); 65 | done)) 66 | ~max_height_seen:(check (fun max_height_seen -> 67 | assert (max_height_seen >= 0); 68 | assert (max_height_seen <= max_height_allowed t))) 69 | ~nodes_by_height:(check Nodes_by_height.invariant)) 70 | ;; 71 | 72 | let create ~max_height_allowed = 73 | { length = 0 74 | ; height_lower_bound = max_height_allowed + 1 75 | ; max_height_seen = 0 76 | ; nodes_by_height = Nodes_by_height.create ~max_height_allowed 77 | } 78 | ;; 79 | 80 | let set_max_height_allowed t max_height_allowed = 81 | if max_height_allowed < t.max_height_seen 82 | then failwiths "cannot set_max_height_allowed less than the max height already seen" 83 | (max_height_allowed, `max_height_seen t.max_height_seen) 84 | [%sexp_of: int * [ `max_height_seen of int ]]; 85 | if debug then assert (is_empty t); 86 | t.nodes_by_height <- Nodes_by_height.create ~max_height_allowed; 87 | ;; 88 | 89 | let add_unless_mem (type a) t (node : a Node.t) = 90 | if node.height_in_adjust_heights_heap = -1 then begin 91 | let height = node.height in 92 | (* We process nodes in increasing order of pre-adjusted height, so it is a bug if we 93 | ever try to add a node that would violate that. *) 94 | if debug then assert (height >= t.height_lower_bound); 95 | (* Whenever we set a node's height, we use [set_height], which enforces this. *) 96 | if debug then assert (height <= max_height_allowed t); 97 | node.height_in_adjust_heights_heap <- height; 98 | t.length <- t.length + 1; 99 | node.next_in_adjust_heights_heap <- Array.get t.nodes_by_height height; 100 | Array.unsafe_set t.nodes_by_height height (Uopt.some (Node.pack node)); 101 | end; 102 | ;; 103 | 104 | let remove_min_exn t = 105 | if debug && is_empty t 106 | then failwiths "Adjust_heights_heap.remove_min of empty heap" t [%sexp_of: t]; 107 | let r = ref t.height_lower_bound in 108 | while Uopt.is_none (Array.get t.nodes_by_height !r) do 109 | incr r; 110 | done; 111 | let height = !r in 112 | t.height_lower_bound <- height; 113 | let node = Uopt.unsafe_value (Array.unsafe_get t.nodes_by_height height) in 114 | node.height_in_adjust_heights_heap <- -1; 115 | t.length <- t.length - 1; 116 | Array.unsafe_set t.nodes_by_height height node.next_in_adjust_heights_heap; 117 | node.next_in_adjust_heights_heap <- Uopt.none; 118 | node; 119 | ;; 120 | 121 | let set_height t (node : _ Node.t) height = 122 | if height > t.max_height_seen then begin 123 | t.max_height_seen <- height; 124 | if height > max_height_allowed t 125 | then failwiths "node with too large height" 126 | (`Height height, `Max (max_height_allowed t)) 127 | [%sexp_of: [ `Height of int ] * [ `Max of int ]]; 128 | end; 129 | node.height <- height; 130 | ;; 131 | 132 | let ensure_height_requirement t ~original_child ~original_parent ~child ~parent = 133 | if debug then assert (Node.is_necessary child); 134 | if debug then assert (Node.is_necessary parent); 135 | if Node.same parent original_child 136 | then failwiths "adding edge made graph cyclic" 137 | (`child original_child, `parent original_parent) 138 | [%sexp_of: [ `child of _ Node.t ] * [ `parent of _ Node.t ]]; 139 | if child.height >= parent.height then begin 140 | add_unless_mem t parent; 141 | (* We set [parent.height] after adding [parent] to the heap, so that [parent] goes 142 | in the heap with its pre-adjusted height. *) 143 | set_height t parent (child.height + 1); 144 | end; 145 | ;; 146 | 147 | let adjust_heights (type a) (type b) 148 | t recompute_heap 149 | ~child:(original_child : a Node.t) 150 | ~parent:(original_parent : b Node.t) = 151 | if verbose 152 | then Debug.ams [%here] "adjust_heights" (`child original_child, `parent original_parent) 153 | [%sexp_of: [ `child of _ Node.t ] * [ `parent of _ Node.t ]]; 154 | if debug then assert (is_empty t); 155 | if debug then assert (original_child.height >= original_parent.height); 156 | t.height_lower_bound <- original_parent.height; 157 | ensure_height_requirement t ~original_child ~original_parent 158 | ~child:original_child ~parent:original_parent; 159 | while length t > 0 do 160 | let module E = struct type t end in 161 | (* This [Obj.magic] is to unpack an existential. *) 162 | let child = (Obj.magic (remove_min_exn t : Should_not_use.t Node.t) : E.t Node.t) in 163 | if Node.is_in_recompute_heap child 164 | then Recompute_heap.increase_height recompute_heap child; 165 | if child.num_parents > 0 then begin 166 | ensure_height_requirement t ~original_child ~original_parent ~child 167 | ~parent:(Uopt.value_exn child.parent0); 168 | for parent_index = 1 to child.num_parents - 1 do 169 | ensure_height_requirement t ~original_child ~original_parent ~child 170 | ~parent:(Uopt.value_exn 171 | (Array.get child.parent1_and_beyond (parent_index - 1))); 172 | done; 173 | end; 174 | match child.kind with 175 | | Bind_lhs_change { all_nodes_created_on_rhs; _ } -> 176 | let r = ref all_nodes_created_on_rhs in 177 | while Uopt.is_some !r do 178 | let node_on_rhs = Uopt.unsafe_value !r in 179 | r := node_on_rhs.next_node_in_same_scope; 180 | if Node.is_necessary node_on_rhs 181 | then ensure_height_requirement t ~original_child ~original_parent ~child 182 | ~parent:node_on_rhs; 183 | done; 184 | | _ -> () 185 | done; 186 | if debug then assert (is_empty t); 187 | if debug then assert (original_child.height < original_parent.height); 188 | ;; 189 | -------------------------------------------------------------------------------- /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 | 11 | open! Core_kernel 12 | open! Import 13 | open Types 14 | 15 | type t [@@deriving sexp_of] 16 | 17 | include Invariant.S with type t := t 18 | 19 | val create : max_height_allowed:int -> t 20 | 21 | val length : t -> int 22 | 23 | (** It is required that all nodes have [n.height <= max_height_allowed t]. Any attempt 24 | to set a node's height larger will raise. 25 | 26 | One can call [set_max_height_allowed] to change the maximum-allowed height. 27 | [set_max_height_allowed t m] raises if [m < max_height_seen t]. *) 28 | val max_height_allowed : t -> int 29 | val set_max_height_allowed : t -> int -> unit 30 | 31 | (** [max_height_seen t] returns the maximum height of any node ever created, not just 32 | nodes currently in use. *) 33 | val max_height_seen : t -> int 34 | 35 | (** [set_height] must be called to change the height of a node, except when clearing the 36 | height to [-1]. This allows the adjust-heights heap to track the maximum height of 37 | all nodes. [set_height] raises if [node.height > max_height_allowed t]. *) 38 | val set_height : t -> _ Node.t -> int -> unit 39 | 40 | (** [adjust_heights t recompute_heap ~child ~parent] is called when [parent] is added as a 41 | parent of [child] and [child.height >= parent.height]. It restores the node height 42 | invariant: [child.height < parent.height] (for [parent] and all its ancestors). 43 | 44 | Pre and post-conditions: 45 | 46 | - [t] is empty. Thus, for all nodes [n], [n.height_in_adjust_heights_heap = -1]. 47 | - For all nodes [n] in [recompute_heap], [n.height = n.height_in_recompute_heap]. 48 | 49 | [adjust_heights] adds a node [n] to the adjust-heights heap when it detects that 50 | [c.height >= n.height] for some child [c] of [n]. It adds [n] with 51 | [n.height_in_adjust_heights_heap] set to the pre-adjusted height of [n], and then sets 52 | [n.height] to [c.height + 1]. [adjust_heights] then does not change 53 | [n.height_in_adjust_heights_heap] until [n] is removed from [t], at which point it is 54 | reset to [-1]. [adjust_heights] may increase [n.height] further as it detects other 55 | children [c] of [n] with [c.height >= n.height]. A node's [height_in_recompute_heap] 56 | changes at most once during [adjust_heights], once the node's final adjusted height is 57 | known. 58 | 59 | Here is the algorithm. 60 | 61 | while [t] is not empty: 62 | 1. remove an [n] in [t] with minimum [n.height_in_adjust_heights_heap]. 63 | 2. [Recompute_heap.increase_height recompute_heap n]. 64 | 3. for all parents [p] of [n], if [n.height >= p.height], then ensure [p] is in [t] 65 | and set [p.height] to [n.height + 1] and 66 | 67 | If [adjust_heights] ever encounters [child] while visiting the ancestors of [parent], 68 | then there is a cycle in the graph and [adjust_heights] raises. 69 | 70 | [adjust_heights] raises if a node's height needs to be increased beyond 71 | [max_height_allowed t]. 72 | *) 73 | val adjust_heights 74 | : t 75 | -> Recompute_heap.t 76 | -> child: _ Node.t 77 | -> parent:_ Node.t 78 | -> unit 79 | -------------------------------------------------------------------------------- /src/alarm.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Alarm = Timing_wheel_ns.Alarm 5 | 6 | type t = Types.Alarm_value.t sexp_opaque Alarm.t 7 | [@@deriving sexp_of] 8 | 9 | let invariant (_ : t) = () 10 | 11 | let null = Alarm.null () 12 | -------------------------------------------------------------------------------- /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_kernel 5 | open! Import 6 | 7 | type t = Types.Alarm.t 8 | [@@deriving sexp_of] 9 | 10 | include Invariant.S with type t := t 11 | 12 | val null : t 13 | -------------------------------------------------------------------------------- /src/alarm_value.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 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.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 -> Step_function.invariant ignore step_function 17 | ;; 18 | end 19 | 20 | type t = Types.Alarm_value.t = 21 | { action : Action.t 22 | (* [next_fired] singly links all alarm values that fire during a single call to 23 | [advance_clock]. *) 24 | ; mutable next_fired : t Uopt.t sexp_opaque 25 | } 26 | [@@deriving fields, sexp_of] 27 | 28 | let invariant t = 29 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 30 | let check f = Invariant.check_field t f in 31 | Fields.iter 32 | ~action:(check Action.invariant) 33 | ~next_fired:ignore) 34 | ;; 35 | 36 | let create action = { action; next_fired = Uopt.none } 37 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Alarm_value end 11 | 12 | include Invariant.S with type t := t 13 | include Sexp_of.S with type t := t 14 | 15 | val create : Action.t -> t 16 | -------------------------------------------------------------------------------- /src/array_fold.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | module Node = Types.Node 5 | 6 | type ('a, 'acc) t = ('a, 'acc) Types.Array_fold.t = 7 | { init : 'acc 8 | ; f : 'acc -> 'a -> 'acc 9 | ; children : 'a Node.t array 10 | } 11 | [@@deriving fields, sexp_of] 12 | 13 | let invariant invariant_a invariant_acc t = 14 | Invariant.invariant [%here] t [%sexp_of: (_, _) t] (fun () -> 15 | let check f = Invariant.check_field t f in 16 | Fields.iter 17 | ~init:(check invariant_acc) 18 | ~f:ignore 19 | ~children:(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/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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Array_fold end 11 | 12 | include Sexp_of.S2 with type ('a, 'b) t := ('a, 'b) t 13 | 14 | include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t 15 | 16 | val compute : (_, 'b) t -> 'b 17 | -------------------------------------------------------------------------------- /src/at.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type t = Types.At.t = 8 | { main : Before_or_after.t Node.t 9 | ; at : Time_ns.t 10 | ; mutable alarm : Alarm.t 11 | } 12 | [@@deriving fields, sexp_of] 13 | 14 | let invariant t = 15 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 16 | let check f = Invariant.check_field t f in 17 | Fields.iter 18 | ~main:(check (fun (main : Before_or_after.t Node.t) -> 19 | match main.kind with 20 | | Invalid -> () 21 | | Const After -> () (* happens once the current time passes [t.at]. *) 22 | | At t' -> assert (phys_equal t t') 23 | | _ -> assert false)) 24 | ~at:ignore 25 | ~alarm:(check Alarm.invariant)) 26 | ;; 27 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.At end 11 | 12 | include Invariant.S with type t := t 13 | include Sexp_of. S with type t := t 14 | -------------------------------------------------------------------------------- /src/at_intervals.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type t = Types.At_intervals.t = 8 | { main : unit Node.t 9 | ; base : Time_ns.t 10 | ; interval : Time_ns.Span.t 11 | ; mutable alarm : Alarm.t 12 | } 13 | [@@deriving fields, sexp_of] 14 | 15 | let invariant t = 16 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 17 | let check f = Invariant.check_field t f in 18 | Fields.iter 19 | ~main:(check (fun (main : _ Node.t) -> 20 | match main.kind with 21 | | Invalid -> () 22 | | At_intervals t' -> assert (phys_equal t t') 23 | | _ -> assert false)) 24 | ~base:ignore 25 | ~interval:(check (fun interval -> assert (Time_ns.Span.is_positive interval))) 26 | ~alarm:(check Alarm.invariant)) 27 | ;; 28 | -------------------------------------------------------------------------------- /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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | include module type of struct include Types.At_intervals end 10 | 11 | include Invariant.S with type t := t 12 | include Sexp_of. S with type t := t 13 | -------------------------------------------------------------------------------- /src/balanced_reducer.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | (* The [data] array is an implicit binary tree with [children_length * 2 - 1] nodes, 5 | with each node being the sum of the two child nodes and the root node being the 0th 6 | node. The leaves of the tree are the last [num_leaves] nodes. 7 | 8 | The children are not necessarily all at the same level of the tree. For instance if 9 | you have 3 children [| a; b; c |]: 10 | 11 | {v 12 | o 13 | / \ 14 | o c 15 | / \ 16 | a b 17 | v} 18 | 19 | We want this tree to be representated as [| o; o; c; a; b |], i.e. we need to apply 20 | first a rotation then a translation to convert an index in [| a; b; c |] to a (leaf) 21 | index in [| o; o; c; a; b |]. *) 22 | type 'a t = 23 | { data : 'a Option_array.t 24 | ; num_leaves : int 25 | ; num_leaves_not_in_bottom_level : int 26 | ; reduce : 'a -> 'a -> 'a 27 | ; sexp_of_a : ('a -> Sexp.t) 28 | } 29 | 30 | let length t = t.num_leaves 31 | 32 | (* {v 33 | parent: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ... 34 | left child: 1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31 33 35 37 39 ... 35 | right child: 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 ... v} *) 36 | let parent_index ~child_index = (child_index - 1) / 2 37 | let left_child_index ~parent_index = parent_index * 2 + 1 38 | let right_child_index ~left_child_index = left_child_index + 1 39 | 40 | (* The first [num_leaves-1] elements are internal nodes of the tree. The next 41 | [num_leaves] elements are the leaves. *) 42 | let num_branches t = t.num_leaves - 1 43 | let index_is_leaf t i = i >= num_branches t 44 | 45 | (* The tree is complete, but not necessarily perfect, so we perform some rotation of the 46 | leaves to ensure that our reductions preserve ordering. *) 47 | let leaf_index t i = 48 | (* The tree layout is level order. Any leaves in the second to last level need to occur 49 | in the array before the leaves in the bottom level. *) 50 | let rotated_index = 51 | let offset_from_start_of_leaves_in_array = i + t.num_leaves_not_in_bottom_level in 52 | if offset_from_start_of_leaves_in_array < t.num_leaves 53 | then offset_from_start_of_leaves_in_array 54 | else offset_from_start_of_leaves_in_array - t.num_leaves 55 | in 56 | (* The leaves occur after the branches in the array. *) 57 | rotated_index + num_branches t 58 | ;; 59 | 60 | let get_leaf t i = Option_array.get t.data (leaf_index t i) 61 | 62 | let to_list t = List.init (length t) ~f:(fun i -> get_leaf t i) 63 | 64 | let sexp_of_t sexp_of_a t = [%sexp (to_list t : a option list)] 65 | 66 | let invariant invariant_a t = 67 | let data = t.data in 68 | for i = 0 to Option_array.length data - 1 do 69 | match Option_array.get data i with 70 | | None -> () 71 | | Some a -> invariant_a a 72 | done; 73 | for i = 0 to num_branches t - 1 do 74 | let left = left_child_index ~parent_index:i in 75 | let right = right_child_index ~left_child_index:left in 76 | let left_is_none = Option_array.is_none data left in 77 | let right_is_none = Option_array.is_none data right in 78 | if Option_array.is_some data i 79 | then assert (not (left_is_none || right_is_none)) 80 | else assert (index_is_leaf t left 81 | || index_is_leaf t right 82 | || left_is_none 83 | || right_is_none); 84 | done 85 | ;; 86 | 87 | let create_exn ?(sexp_of_a = [%sexp_of: _]) () ~len:num_leaves ~reduce = 88 | if num_leaves < 1 89 | then raise_s [%message 90 | "non-positive number of leaves in balanced reducer" (num_leaves : int)]; 91 | let num_branches = num_leaves - 1 in 92 | let num_leaves_not_in_bottom_level = Int.ceil_pow2 num_leaves - num_leaves in 93 | let data = Option_array.create ~len:(num_branches + num_leaves) in 94 | { data 95 | ; num_leaves 96 | ; num_leaves_not_in_bottom_level 97 | ; reduce 98 | ; sexp_of_a } 99 | ;; 100 | 101 | let set_exn t i a = 102 | if i < 0 103 | then raise_s [%message 104 | "attempt to set negative index in balanced reducer" ~index:(i : int)]; 105 | let length = t.num_leaves in 106 | if i >= length 107 | then raise_s [%message 108 | "attempt to set out of bounds index in balanced reducer" 109 | ~index:(i : int) 110 | (length : int)]; 111 | let data = t.data in 112 | let i = ref (leaf_index t i) in 113 | Option_array.set_some data !i a; 114 | while !i <> 0 do 115 | let parent = parent_index ~child_index:!i in 116 | if Option_array.is_none data parent 117 | then i := 0 118 | else ( 119 | Option_array.unsafe_set_none data parent; 120 | i := parent); 121 | done; 122 | ;; 123 | 124 | let rec compute_exn t i = 125 | if Option_array.is_some t.data i 126 | then Option_array.unsafe_get_some_exn t.data i 127 | else ( 128 | let left = left_child_index ~parent_index:i in 129 | let right = right_child_index ~left_child_index:left in 130 | if left >= Option_array.length t.data 131 | then ( 132 | (* If we get here, the parent was an unset leaf. *) 133 | let sexp_of_a = t.sexp_of_a in 134 | raise_s [%message 135 | "attempt to compute balanced reducer with unset elements" 136 | ~balanced_reducer:(t : a t)]); 137 | let a = t.reduce (compute_exn t left) (compute_exn t right) in 138 | Option_array.unsafe_set_some t.data i a; 139 | a) 140 | ;; 141 | 142 | let compute_exn t = compute_exn t 0 143 | -------------------------------------------------------------------------------- /src/balanced_reducer.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | A [Balanced_reducer.t] is a mutable non-empty array that tracks the result of folding 4 | an associative operation ([reduce]) over the array as its elements change. *) 5 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | type 'a t [@@deriving sexp_of] 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | 13 | (** [create_exn ~len ~reduce] creates an array containing [len] [None]s and prepares an 14 | incremental fold with [reduce]. It raises if [len < 1]. *) 15 | val create_exn 16 | : ?sexp_of_a : ('a -> Sexp.t) (** for improved error messages *) 17 | -> unit 18 | -> len : int 19 | -> reduce : ('a -> 'a -> 'a) 20 | -> 'a t 21 | 22 | (** [set_exn t i a] updates the value at index [i] to [Some a]. It raises if [i] is out 23 | of bounds. *) 24 | val set_exn : 'a t -> int -> 'a -> unit 25 | 26 | (** [compute_exn t] computes the value of the fold. It raises if any values of the array 27 | are [None]. *) 28 | val compute_exn : 'a t -> 'a 29 | -------------------------------------------------------------------------------- /src/before_or_after.ml: -------------------------------------------------------------------------------- 1 | type t = Before | After 2 | [@@deriving sexp_of] 3 | -------------------------------------------------------------------------------- /src/before_or_after.mli: -------------------------------------------------------------------------------- 1 | type t = Before | After 2 | [@@deriving sexp_of] 3 | -------------------------------------------------------------------------------- /src/bind.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Bind = Types.Bind 6 | module Node = Types.Node 7 | module Packed_node = Types.Packed_node 8 | module Scope = Types.Scope 9 | 10 | type ('a, 'b) t = ('a, 'b) Bind.t = 11 | { main : 'b Node.t 12 | (* [f] is the user-supplied function that we run each time [t.lhs] changes. It is 13 | mutable only so we can clear it when [t] is invalidated. *) 14 | ; mutable f : 'a -> 'b Node.t 15 | ; lhs : 'a Node.t 16 | ; lhs_change : unit Node.t 17 | (* [rhs] is initially [none], and after that is [some] of the result of the most recent 18 | call to [f]. *) 19 | ; mutable rhs : 'b Node.t Uopt.t 20 | (* [rhs_scope] is the scope in which [t.f] is run, i.e. it is [Scope.Bind t]. It is 21 | [mutable] only to avoid a [let rec] during creation. *) 22 | ; mutable rhs_scope : Scope.t 23 | (* [all_nodes_created_on_rhs] is the head of the singly-linked list of nodes created on 24 | the right-hand side of [t], i.e. in [t.rhs_scope]. *) 25 | ; mutable all_nodes_created_on_rhs : Packed_node.t Uopt.t 26 | } 27 | [@@deriving fields, sexp_of] 28 | 29 | let same (t1 : (_, _) t) (t2 : (_, _) t) = phys_same t1 t2 30 | 31 | let is_valid t = 32 | match t.main.kind with 33 | | Invalid -> false 34 | | _ -> true 35 | ;; 36 | 37 | let iter_nodes_created_on_rhs t ~f = 38 | let r = ref t.all_nodes_created_on_rhs in 39 | while Uopt.is_some !r do 40 | let node_on_rhs = Uopt.unsafe_value !r in 41 | r := node_on_rhs.next_node_in_same_scope; 42 | f node_on_rhs; 43 | done; 44 | ;; 45 | 46 | let invariant _invariant_a _invariant_b t = 47 | Invariant.invariant [%here] t [%sexp_of: (_, _) t] (fun () -> 48 | let check f = Invariant.check_field t f in 49 | Fields.iter 50 | ~main:(check (fun (main : _ Node.t) -> 51 | match main.kind with 52 | | Invalid -> () 53 | | Bind_main t' -> assert (same t t'); 54 | | _ -> assert false)) 55 | ~f:ignore 56 | ~lhs:ignore 57 | ~lhs_change:(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:(check (function 65 | | Scope.Top -> assert false 66 | | Scope.Bind t' -> assert (same t t'))) 67 | ~all_nodes_created_on_rhs:(check (fun _ -> 68 | iter_nodes_created_on_rhs t ~f:(fun node -> 69 | assert (phys_equal node.created_in t.rhs_scope); 70 | if Node.is_necessary node then assert (t.lhs_change.height < node.height))))) 71 | ;; 72 | -------------------------------------------------------------------------------- /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 4 | of type ['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 12 | the [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 | 28 | open! Core_kernel 29 | open! Import 30 | 31 | include module type of struct include Types.Bind end 32 | 33 | include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t 34 | include Sexp_of. S2 with type ('a, 'b) t := ('a, 'b) t 35 | 36 | (** [is_valid t] iff the scope in which [t] was created is valid. *) 37 | val is_valid : (_, _) t -> bool 38 | 39 | val iter_nodes_created_on_rhs : (_, _) t -> f:(Types.Packed_node.t -> unit) -> unit 40 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | 4 | include Config_intf 5 | 6 | module Default () = struct 7 | let bind_lhs_change_should_invalidate_rhs = true 8 | 9 | let start = Time_ns.now () 10 | 11 | module Alarm_precision = Timing_wheel_ns.Alarm_precision 12 | 13 | let timing_wheel_config = 14 | let alarm_precision = Alarm_precision.about_one_millisecond in 15 | let level_bits = [ 14; 13; 5 ] in 16 | Timing_wheel_ns.Config.create 17 | ~alarm_precision 18 | ~level_bits:(Timing_wheel_ns.Level_bits.create_exn level_bits) 19 | () 20 | ;; 21 | end 22 | -------------------------------------------------------------------------------- /src/config.mli: -------------------------------------------------------------------------------- 1 | include Config_intf.Config 2 | -------------------------------------------------------------------------------- /src/config_intf.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module type Incremental_config = sig 5 | 6 | (** [bind_lhs_change_should_invalidate_rhs = false] is a hack to enable code that worked 7 | with earlier versions of Incremental that did not support invalidation to be more 8 | easily used with this version of Incremental. Except in that situation, one 9 | should leave this as true, and that is what [Default] does. *) 10 | val bind_lhs_change_should_invalidate_rhs : bool 11 | 12 | val start : Time_ns.t 13 | 14 | val timing_wheel_config : Timing_wheel_ns.Config.t 15 | end 16 | 17 | module type Config = sig 18 | module type Incremental_config = Incremental_config 19 | 20 | (** A default timing-wheel configuration, with one millisecond precision with alarms up 21 | to 30 days in the future. *) 22 | module Default () : Incremental_config 23 | end 24 | -------------------------------------------------------------------------------- /src/cutoff.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | type 'a t = 5 | (* We specialize some cutoffs to 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 | | F of (old_value:'a -> new_value:'a -> bool) 13 | [@@deriving sexp_of] 14 | 15 | let invariant _ t = 16 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 17 | match t with 18 | | Always -> () 19 | | Never -> () 20 | | Phys_equal -> () 21 | | Compare _ -> () 22 | | F _ -> ()) 23 | ;; 24 | 25 | let create f = F f 26 | 27 | let of_compare f = Compare f 28 | 29 | let never = Never 30 | let always = Always 31 | 32 | let poly_equal = F (fun ~old_value ~new_value -> Poly.equal old_value new_value) 33 | 34 | let should_cutoff t ~old_value ~new_value = 35 | match t with 36 | | Phys_equal -> phys_equal old_value new_value 37 | | Never -> false 38 | | Always -> true 39 | | Compare f -> f old_value new_value = 0 40 | | F f -> f ~old_value ~new_value 41 | ;; 42 | 43 | let equal t1 t2 = 44 | match t1, t2 with 45 | | Always , Always -> true 46 | | Always , _ -> false 47 | | Never , Never -> true 48 | | Never , _ -> false 49 | | Phys_equal, Phys_equal -> true 50 | | Phys_equal, _ -> false 51 | | Compare f1, Compare f2 -> phys_equal f1 f2 52 | | Compare _ , _ -> false 53 | | F f1, F f2 -> phys_equal f1 f2 54 | | F _, _ -> false 55 | ;; 56 | 57 | let phys_equal = Phys_equal 58 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | type 'a t [@@deriving sexp_of] 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | 14 | val create : (old_value:'a -> new_value:'a -> bool) -> 'a t 15 | val of_compare : ('a -> 'a -> int) -> 'a t 16 | 17 | val always : _ t 18 | val never : _ t 19 | val phys_equal : _ t 20 | val poly_equal : _ t 21 | 22 | val equal : 'a t -> 'a t -> bool 23 | 24 | val should_cutoff : 'a t -> old_value:'a -> new_value:'a -> bool 25 | -------------------------------------------------------------------------------- /src/debug.mlh: -------------------------------------------------------------------------------- 1 | [%%define JSC_DEBUG false] 2 | -------------------------------------------------------------------------------- /src/expert.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | module Node = Types.Node 5 | 6 | type 'a edge = 'a Types.Expert.edge = 7 | { child : 'a Node.t 8 | ; on_change : 'a -> unit 9 | (* [index] is defined whenever the [edge] is in the [children] of some [t]. Then it is 10 | the index of this [edge] in that [children] array. It might seem redundant with all 11 | the other indexes we have, but it is necessary to remove children. The index may 12 | change as sibling children are removed. *) 13 | ; mutable index : int Uopt.t 14 | } 15 | [@@deriving sexp_of] 16 | 17 | type packed_edge = Types.Expert.packed_edge = 18 | | E : 'a edge -> packed_edge 19 | [@@deriving sexp_of] 20 | 21 | type 'a t = 'a Types.Expert.t = 22 | { f : unit -> 'a 23 | ; on_observability_change : is_now_observable:bool -> unit 24 | ; mutable children : packed_edge Uopt.t Array.t 25 | ; mutable num_children : int 26 | (* When set, makes the node of [t] stale. It is set when the set of children changes. 27 | Otherwise the normal check of staleness (comparing the [changed_at] field of 28 | children and the [recomputed_at] field for the node of [t]) would not be enough. 29 | This plays a role similar to the cutoff of [Never] for the lhs-change of binds, but 30 | we don't have a special child. *) 31 | ; mutable force_stale : bool 32 | (* The number of invalid children that point to us. Used to determine whether the node 33 | of [t] needs to invalidated, without iterating over all the children. This is not 34 | needed for other nodes, because there are no other nodes that have a potentially 35 | large and dynamic set of children. *) 36 | ; mutable num_invalid_children : int 37 | (* Whether we will fire the [on_change] callbacks for all children when the node of [t] 38 | itself runs. Used to make sure we rerun everything after [t] switches from 39 | unobservable and back to observable. *) 40 | ; mutable will_fire_all_callbacks : bool 41 | } 42 | [@@deriving sexp_of] 43 | 44 | let invariant _invariant_a { f = _ 45 | ; children 46 | ; num_children 47 | ; force_stale = _ 48 | ; num_invalid_children 49 | ; on_observability_change = _ 50 | ; will_fire_all_callbacks = _ 51 | } = 52 | assert (num_children <= Array.length children); 53 | ignore num_invalid_children; (* invariant is below, because we need some context *) 54 | Array.iteri children 55 | ~f:(fun i uopt -> 56 | match i < num_children with 57 | | true -> 58 | let E r = Uopt.value_exn uopt in 59 | [%test_result:int] (Uopt.value_exn r.index) ~expect:i 60 | | false -> assert (Uopt.is_none uopt)); 61 | ;; 62 | 63 | let invariant_about_num_invalid_children 64 | { children; num_children; num_invalid_children; _ } ~is_necessary = 65 | if not is_necessary 66 | then 67 | [%test_result: int] num_invalid_children ~expect:0 68 | else begin 69 | let count_invalid_children = ref 0 in 70 | for i = 0 to num_children - 1 do 71 | let E r = Uopt.value_exn 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 | end 76 | ;; 77 | 78 | let create ~f ~on_observability_change = 79 | { f 80 | ; on_observability_change 81 | ; children = [||] 82 | ; num_children = 0 83 | ; force_stale = false 84 | ; num_invalid_children = 0 85 | ; will_fire_all_callbacks = true 86 | } 87 | ;; 88 | 89 | let make_stale t = 90 | if t.force_stale 91 | then `Already_stale 92 | else begin 93 | t.force_stale <- true; 94 | `Ok 95 | end 96 | ;; 97 | 98 | let incr_invalid_children t = 99 | t.num_invalid_children <- t.num_invalid_children + 1; 100 | ;; 101 | 102 | let decr_invalid_children t = 103 | t.num_invalid_children <- t.num_invalid_children - 1; 104 | ;; 105 | 106 | let make_space_for_child_if_necessary t = 107 | if t.num_children >= Array.length t.children then begin 108 | if debug then assert (t.num_children = Array.length t.children); 109 | let new_max = Int.max 2 (2 * Array.length t.children) in 110 | t.children <- Array.realloc t.children ~len:new_max Uopt.none; 111 | end; 112 | ;; 113 | 114 | let add_child_edge t packed_edge = 115 | let E edge = packed_edge in 116 | assert (Uopt.is_none edge.index); 117 | make_space_for_child_if_necessary t; 118 | let new_child_index = t.num_children in 119 | edge.index <- Uopt.some new_child_index; 120 | t.children.( new_child_index ) <- Uopt.some packed_edge; 121 | t.num_children <- t.num_children + 1; 122 | t.force_stale <- true; 123 | (* We will bump the number of invalid children if necessary when connecting child and 124 | parent. Same thing for running the [on_change] callbacks. *) 125 | new_child_index 126 | ;; 127 | 128 | let swap_children t ~child_index1 ~child_index2 = 129 | let E edge1 = Uopt.value_exn t.children.( child_index1 ) in 130 | let E edge2 = Uopt.value_exn t.children.( child_index2 ) in 131 | edge1.index <- Uopt.some child_index2; 132 | edge2.index <- Uopt.some child_index1; 133 | Array.swap t.children child_index1 child_index2; 134 | ;; 135 | 136 | let last_child_edge_exn t = 137 | let last_index = t.num_children - 1 in 138 | Uopt.value_exn t.children.( last_index ) 139 | ;; 140 | 141 | let remove_last_child_edge_exn t = 142 | let last_index = t.num_children - 1 in 143 | let packed_edge_opt = t.children.( last_index ) in 144 | t.children.( last_index ) <- Uopt.none; 145 | t.num_children <- last_index; 146 | t.force_stale <- true; 147 | assert (Uopt.is_some packed_edge_opt); 148 | let E edge = Uopt.unsafe_value packed_edge_opt in 149 | edge.index <- Uopt.none; 150 | ;; 151 | 152 | let before_main_computation t = 153 | if t.num_invalid_children > 0 154 | then `Invalid 155 | else begin 156 | t.force_stale <- false; 157 | let will_fire_all_callbacks = t.will_fire_all_callbacks in 158 | t.will_fire_all_callbacks <- false; 159 | if will_fire_all_callbacks 160 | then ( 161 | for i = 0 to t.num_children - 1; do 162 | let E r = Uopt.value_exn t.children.( i ) in 163 | r.on_change (Uopt.value_exn r.child.value_opt); 164 | done); 165 | `Ok 166 | end 167 | ;; 168 | 169 | let observability_change t ~is_now_observable = 170 | t.on_observability_change ~is_now_observable; 171 | if not is_now_observable 172 | then begin 173 | t.will_fire_all_callbacks <- true; 174 | (* If we don't reset num_invalid_children, we would double count them: just imagine 175 | what happens we if reconnect/disconnect/reconnect/disconnect with an invalid 176 | child. *) 177 | t.num_invalid_children <- 0; 178 | end 179 | ;; 180 | 181 | let run_edge_callback t ~child_index = 182 | if not t.will_fire_all_callbacks then begin 183 | let E r = Uopt.value_exn t.children.( child_index ) in 184 | (* This value is not necessarily set, because we try to run this when connecting the 185 | node to its children, which could be before they have run even once. Also the node 186 | could be invalid. *) 187 | if Uopt.is_some r.child.value_opt 188 | then r.on_change (Uopt.unsafe_value r.child.value_opt) 189 | end 190 | ;; 191 | -------------------------------------------------------------------------------- /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_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Expert end 11 | 12 | include Invariant.S1 with type 'a t := 'a t 13 | include Sexp_of.S1 with type 'a t := 'a t 14 | val sexp_of_edge : ('a -> Sexp.t) -> 'a edge -> Sexp.t 15 | 16 | val invariant_about_num_invalid_children : _ t -> is_necessary:bool -> unit 17 | 18 | val create 19 | : f : (unit -> 'a) 20 | -> on_observability_change : (is_now_observable:bool -> unit) 21 | -> 'a t 22 | 23 | val make_stale : _ t -> [ `Already_stale | `Ok ] 24 | 25 | val incr_invalid_children : _ t -> unit 26 | val decr_invalid_children : _ t -> unit 27 | 28 | (** Returns the index of this new edge. *) 29 | val add_child_edge : _ t -> packed_edge -> int 30 | 31 | val swap_children : _ t -> child_index1:int -> child_index2:int -> unit 32 | val last_child_edge_exn : _ t -> packed_edge 33 | val remove_last_child_edge_exn : _ t -> unit 34 | 35 | val before_main_computation : _ t -> [ `Invalid | `Ok ] 36 | 37 | val observability_change : _ t -> is_now_observable:bool -> unit 38 | 39 | val run_edge_callback : _ t -> child_index:int -> unit 40 | -------------------------------------------------------------------------------- /src/expert1.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 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 = 8 | { child; on_change; index = Uopt.none } 9 | ;; 10 | 11 | let value state (t : _ t) = 12 | if debug then begin 13 | State.Expert.assert_currently_running_node_is_parent state 14 | t.child "Dependency.value" 15 | end; 16 | (* Not exposing the _exn, because this function is advertised as being usable only 17 | inside the callbacks of parents, where it will not raise. *) 18 | Node.value_exn t.child 19 | ;; 20 | end 21 | 22 | module Node = struct 23 | type nonrec 'a t = 'a Node.t [@@deriving sexp_of] 24 | 25 | let create state ?(on_observability_change = fun ~is_now_observable:_ -> ()) f = 26 | State.Expert.create state ~on_observability_change f 27 | ;; 28 | 29 | let make_stale = State.Expert.make_stale 30 | let watch = Fn.id 31 | let invalidate = State.Expert.invalidate 32 | let add_dependency = State.Expert.add_dependency 33 | let remove_dependency = State.Expert.remove_dependency 34 | end 35 | -------------------------------------------------------------------------------- /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 4 | defunctorized, so it's easier to use from the inside of incremental. *) 5 | 6 | module Dependency : sig 7 | type 'a t [@@deriving sexp_of] 8 | val create : ?on_change:('a -> unit) -> 'a Node.t -> 'a t 9 | val value : State.t -> 'a t -> 'a 10 | end 11 | 12 | module Node : sig 13 | type 'a t [@@deriving sexp_of] 14 | val create 15 | : State.t 16 | -> ?on_observability_change : (is_now_observable:bool -> unit) 17 | -> (unit -> 'a) 18 | -> 'a t 19 | val watch : 'a t -> 'a Node.t 20 | val make_stale : State.t -> _ t -> unit 21 | val invalidate : State.t -> _ t -> unit 22 | val add_dependency : State.t -> _ t -> _ Dependency.t -> unit 23 | val remove_dependency : State.t -> _ t -> _ Dependency.t -> unit 24 | end 25 | -------------------------------------------------------------------------------- /src/freeze.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type 'a t = 'a Types.Freeze.t = 8 | { main : 'a Node.t 9 | ; child : 'a Node.t 10 | ; only_freeze_when : ('a -> bool) 11 | } 12 | [@@deriving fields, sexp_of] 13 | 14 | let invariant _invariant_a t = 15 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 16 | let check f = Invariant.check_field t f in 17 | Fields.iter 18 | ~main:(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/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 4 | and doesn't change thereafter. 5 | *) 6 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Freeze 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.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type 'a t = 'a Types.If_then_else.t = 8 | { main : 'a Node.t 9 | ; test : bool Node.t 10 | ; test_change : unit Node.t 11 | ; mutable current_branch : 'a Node.t Uopt.t 12 | ; then_ : 'a Node.t 13 | ; else_ : 'a Node.t 14 | } 15 | [@@deriving fields, sexp_of] 16 | 17 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 18 | 19 | let invariant _invariant_a t = 20 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 21 | let check f = Invariant.check_field t f in 22 | Fields.iter 23 | ~main:(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:(check (fun (test_change : _ Node.t) -> 30 | match test_change.kind with 31 | | Invalid -> () 32 | | If_test_change t' -> assert (same t t') 33 | | _ -> assert false)) 34 | ~current_branch:(check (fun current_branch -> 35 | if Uopt.is_some current_branch then begin 36 | let current_branch = Uopt.value_exn current_branch in 37 | assert (phys_equal current_branch t.then_ || phys_equal current_branch t.else_) 38 | end)) 39 | ~then_:ignore 40 | ~else_:ignore) 41 | ;; 42 | -------------------------------------------------------------------------------- /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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | include module type of struct include Types.If_then_else end 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | include Sexp_of.S1 with type 'a t := 'a t 13 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | [%%import "debug.mlh"] 2 | 3 | open Core_kernel 4 | 5 | include Int.Replace_polymorphic_compare 6 | 7 | (* All [assert]s and other checks throughout the code are guarded by [if debug]. The 8 | DEBUG variable is set in the lib [incremental_lib] and unset in the lib 9 | [incremental_debug], but apart from that they are identical. Tests are run with both 10 | the production and debug lib, and users can choose to build with the debug library, if 11 | they suspect they found a bug in incremental. *) 12 | 13 | [%%if JSC_DEBUG] 14 | let debug = true 15 | [%%else] 16 | let debug = false 17 | [%%endif] 18 | 19 | (* All debug messages throughout the code are guarded by [if verbose]. *) 20 | let verbose = false 21 | 22 | let concat = String.concat 23 | 24 | let tag name a sexp_of_a = (name, a) |> [%sexp_of: string * a] 25 | 26 | let sexp_of_time_ns = 27 | ref (fun t -> 28 | sexp_of_string 29 | (sprintf "Time_ns.of_int_ns_since_epoch %d" (Time_ns.to_int_ns_since_epoch t))) 30 | ;; 31 | 32 | let sexp_of_time_ns_span = 33 | ref (fun t -> 34 | sexp_of_string 35 | (sprintf "Time_ns.Span.of_int_ns %d" (Time_ns.Span.to_int_ns t))) 36 | ;; 37 | 38 | module Time_ns = struct 39 | include (Time_ns : module type of struct include Time_ns end 40 | with module Span := Time_ns.Span) 41 | let sexp_of_t t = !sexp_of_time_ns t 42 | 43 | module Span = struct 44 | include Time_ns.Span 45 | let sexp_of_t t = !sexp_of_time_ns_span t 46 | end 47 | end 48 | 49 | let () = Debug.should_print_backtrace := false 50 | 51 | module Array = struct 52 | include Array 53 | 54 | (* Not defining aliases in production mode, since they break type specialization of 55 | array accesses. *) 56 | [%%if JSC_DEBUG] 57 | let unsafe_get = get 58 | let unsafe_set = set 59 | [%%endif] 60 | 61 | (* Requires [len >= length t]. *) 62 | let realloc t ~len a = 63 | let new_t = create ~len a in 64 | Array.blit 65 | ~src:t ~src_pos:0 66 | ~dst:new_t ~dst_pos:0 67 | ~len:(length t); 68 | new_t 69 | ;; 70 | end 71 | 72 | module Uopt = struct 73 | include Uopt 74 | let unsafe_value = if debug then value_exn else unsafe_value 75 | end 76 | -------------------------------------------------------------------------------- /src/incremental_kernel.ml: -------------------------------------------------------------------------------- 1 | (* This module is mostly a wrapper around [State] functions. *) 2 | 3 | open! Core_kernel 4 | open! Import 5 | 6 | include Incremental_kernel_intf 7 | 8 | module type Incremental_config = Config.Incremental_config 9 | 10 | module Config = Config 11 | 12 | module Make_with_config (Incremental_config : Incremental_config) () = struct 13 | 14 | module Before_or_after = Before_or_after 15 | 16 | module Cutoff = Cutoff 17 | 18 | module State = struct 19 | 20 | include State 21 | 22 | let t = create (module Incremental_config) ~max_height_allowed:128 23 | end 24 | 25 | let state = State.t 26 | 27 | module Scope = struct 28 | 29 | include Scope 30 | 31 | let current () = state.current_scope 32 | 33 | let within t ~f = State.within_scope state t ~f 34 | 35 | end 36 | 37 | include Node 38 | 39 | module Node_update = On_update_handler.Node_update 40 | 41 | type 'a incremental = 'a t 42 | 43 | let const a = State.const state a 44 | let return = const 45 | 46 | let observe ?should_finalize t = State.create_observer state t ?should_finalize 47 | 48 | let map t1 ~f = State.map state t1 ~f 49 | let map2 t1 t2 ~f = State.map2 state t1 t2 ~f 50 | let map3 t1 t2 t3 ~f = State.map3 state t1 t2 t3 ~f 51 | let map4 t1 t2 t3 t4 ~f = State.map4 state t1 t2 t3 t4 ~f 52 | let map5 t1 t2 t3 t4 t5 ~f = State.map5 state t1 t2 t3 t4 t5 ~f 53 | let map6 t1 t2 t3 t4 t5 t6 ~f = State.map6 state t1 t2 t3 t4 t5 t6 ~f 54 | let map7 t1 t2 t3 t4 t5 t6 t7 ~f = State.map7 state t1 t2 t3 t4 t5 t6 t7 ~f 55 | let map8 t1 t2 t3 t4 t5 t6 t7 t8 ~f = State.map8 state t1 t2 t3 t4 t5 t6 t7 t8 ~f 56 | let map9 t1 t2 t3 t4 t5 t6 t7 t8 t9 ~f = State.map9 state t1 t2 t3 t4 t5 t6 t7 t8 t9 ~f 57 | 58 | let bind t ~f = State.bind state t ~f 59 | let bind2 t1 t2 ~f = State.bind2 state t1 t2 ~f 60 | let bind3 t1 t2 t3 ~f = State.bind3 state t1 t2 t3 ~f 61 | let bind4 t1 t2 t3 t4 ~f = State.bind4 state t1 t2 t3 t4 ~f 62 | 63 | module Infix = struct 64 | let ( >>| ) t f = map t ~f 65 | let ( >>= ) t f = bind t ~f 66 | end 67 | 68 | include Infix 69 | 70 | let join t = State.join state t 71 | 72 | let if_ test ~then_ ~else_ = State.if_ state test ~then_ ~else_ 73 | 74 | let lazy_from_fun f = State.lazy_from_fun state ~f 75 | 76 | let default_hash_table_initial_size = State.default_hash_table_initial_size 77 | 78 | let memoize_fun_by_key ?initial_size hashable project_key f = 79 | State.memoize_fun_by_key ?initial_size state hashable project_key f 80 | ;; 81 | 82 | let memoize_fun ?initial_size hashable f = 83 | memoize_fun_by_key ?initial_size hashable Fn.id f 84 | ;; 85 | 86 | let array_fold ts ~init ~f = State.array_fold state ts ~init ~f 87 | 88 | let reduce_balanced ts ~f ~reduce = 89 | Reduce_balanced.create state ts ~f ~reduce 90 | ;; 91 | 92 | let unordered_array_fold ?full_compute_every_n_changes ts ~init ~f ~f_inverse = 93 | State.unordered_array_fold state ts ~init ~f ~f_inverse 94 | ?full_compute_every_n_changes 95 | ;; 96 | 97 | let opt_unordered_array_fold ?full_compute_every_n_changes ts ~init ~f ~f_inverse = 98 | State.opt_unordered_array_fold state ts ~init ~f ~f_inverse 99 | ?full_compute_every_n_changes 100 | ;; 101 | 102 | let all ts = State.all state ts 103 | let exists ts = State.exists state ts 104 | let for_all ts = State.for_all state ts 105 | 106 | let sum ?full_compute_every_n_changes ts ~zero ~add ~sub = 107 | State.sum state ?full_compute_every_n_changes ts ~zero ~add ~sub 108 | ;; 109 | 110 | let opt_sum ?full_compute_every_n_changes ts ~zero ~add ~sub = 111 | State.opt_sum state ?full_compute_every_n_changes ts ~zero ~add ~sub 112 | ;; 113 | 114 | let sum_int ts = State.sum_int state ts 115 | let sum_float ts = State.sum_float state ts 116 | 117 | module Var = struct 118 | 119 | include Var 120 | 121 | let create ?use_current_scope value = State.create_var ?use_current_scope state value 122 | 123 | let set t value = State.set_var state t value 124 | 125 | let value t = t.value 126 | 127 | let watch t = t.watch 128 | 129 | (* We override [sexp_of_t] to just show the value, rather than the internal 130 | representation. *) 131 | let sexp_of_t sexp_of_a t = t.value |> [%sexp_of: a] 132 | 133 | end 134 | 135 | module Observer = struct 136 | 137 | include Observer 138 | 139 | module Update = struct 140 | type 'a t = 141 | | Initialized of 'a 142 | | Changed of 'a * 'a 143 | | Invalidated 144 | [@@deriving compare, sexp_of] 145 | end 146 | 147 | let on_update_exn t ~(f : _ Update.t -> unit) = 148 | State.observer_on_update_exn state t 149 | ~f:(function 150 | | Necessary a -> f (Initialized a) 151 | | Changed (a1, a2) -> f (Changed (a1, a2)) 152 | | Invalidated -> f Invalidated 153 | | Unnecessary -> 154 | failwiths "Incremental bug -- Observer.on_update_exn got unexpected update Unnecessary" 155 | t [%sexp_of: _ t]) 156 | ;; 157 | 158 | let disallow_future_use t = State.disallow_future_use state !t 159 | let value t = State.observer_value state t 160 | let value_exn t = State.observer_value_exn state t 161 | 162 | (* We override [sexp_of_t] to just show the value, rather than the internal 163 | representation. *) 164 | let sexp_of_t sexp_of_a t = value t |> [%sexp_of: a Or_error.t] 165 | 166 | end 167 | 168 | let alarm_precision = Timing_wheel_ns.alarm_precision state.timing_wheel 169 | 170 | let now () = State.now state 171 | 172 | let watch_now () = state.now.watch 173 | 174 | let at time = State.at state time 175 | let after span = State.after state span 176 | let at_intervals span = State.at_intervals state span 177 | let advance_clock ~to_ = State.advance_clock state ~to_ 178 | let step_function ~init steps = State.step_function state ~init steps 179 | let snapshot t ~at ~before = State.snapshot state t ~at ~before 180 | 181 | let freeze ?(when_ = fun _ -> true) t = State.freeze state t ~only_freeze_when:when_ 182 | 183 | let depend_on t ~depend_on = State.depend_on state t ~depend_on 184 | 185 | let necessary_if_alive input = State.necessary_if_alive state input 186 | 187 | module Update = On_update_handler.Node_update 188 | 189 | let on_update t ~f = State.node_on_update state t ~f 190 | 191 | let stabilize () = State.stabilize state 192 | 193 | let am_stabilizing () = State.am_stabilizing state 194 | 195 | let save_dot file = State.save_dot state file 196 | 197 | (* We override [sexp_of_t] to show just the value, rather than the internal 198 | representation. We only show the value if it is necessary and valid. *) 199 | let sexp_of_t sexp_of_a t = 200 | if not (is_valid t) 201 | then "" |> [%sexp_of: string] 202 | else if not (is_necessary t) 203 | then "" |> [%sexp_of: string] 204 | else if Uopt.is_none t.value_opt 205 | then "" |> [%sexp_of: string] 206 | else unsafe_value t |> [%sexp_of: a] 207 | ;; 208 | 209 | module Expert = struct 210 | module Dependency = struct 211 | include Expert1.Dependency 212 | let value t = value State.t t 213 | end 214 | module Node = struct 215 | include Expert1.Node 216 | 217 | let create ?on_observability_change f = 218 | Expert1.Node.create State.t ?on_observability_change f 219 | ;; 220 | 221 | let make_stale t = Expert1.Node.make_stale state t 222 | 223 | let invalidate t = Expert1.Node.invalidate State.t t 224 | 225 | let add_dependency t edge = Expert1.Node.add_dependency State.t t edge 226 | 227 | let remove_dependency t edge = Expert1.Node.remove_dependency State.t t edge 228 | end 229 | end 230 | 231 | module Let_syntax = struct 232 | let return = return 233 | let ( >>| ) = ( >>| ) 234 | let ( >>= ) = ( >>= ) 235 | 236 | module Let_syntax = struct 237 | let bind = bind 238 | let map = map 239 | 240 | let both t1 t2 = map2 t1 t2 ~f:(fun x1 x2 -> (x1, x2)) 241 | 242 | module Open_on_rhs = struct 243 | let watch = Var.watch 244 | end 245 | end 246 | end 247 | end 248 | 249 | module Make () = Make_with_config (Config.Default ()) () 250 | 251 | module Incremental = struct 252 | module Make = Make 253 | end 254 | 255 | module Incremental_intf = struct 256 | module type S = S 257 | end 258 | 259 | module Private = struct 260 | module Balanced_reducer = Balanced_reducer 261 | include Import 262 | end 263 | -------------------------------------------------------------------------------- /src/incremental_kernel.mli: -------------------------------------------------------------------------------- 1 | include Incremental_kernel_intf.Incremental_kernel (** @inline *) 2 | 3 | -------------------------------------------------------------------------------- /src/internal_observer.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Internal_observer 4 | 5 | module Packed_ = struct 6 | include Types.Packed_internal_observer 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 | 15 | let set_prev_in_all (T t1) t2 = t1.prev_in_all <- t2 16 | let set_next_in_all (T t1) t2 = t1.next_in_all <- t2 17 | end 18 | 19 | module State = struct 20 | type t = Types.Internal_observer.State.t = Created | In_use | Disallowed | Unlinked 21 | [@@deriving sexp_of] 22 | end 23 | 24 | type 'a t = 'a Types.Internal_observer.t = 25 | { (* State transitions: 26 | 27 | {v 28 | Created --> In_use --> Disallowed --> Unlinked 29 | | ^ 30 | \-------------------------------------/ 31 | v} 32 | *) 33 | mutable state : State.t 34 | ; observing : 'a Node.t 35 | ; mutable on_update_handlers : 'a On_update_handler.t list 36 | (* [{prev,next}_in_all] doubly link all observers in [state.all_observers]. *) 37 | ; mutable prev_in_all : Packed_.t Uopt.t 38 | ; mutable next_in_all : Packed_.t Uopt.t 39 | (* [{prev,next}_in_observing] doubly link all observers of [observing]. *) 40 | ; mutable prev_in_observing : 'a t sexp_opaque Uopt.t 41 | ; mutable next_in_observing : 'a t sexp_opaque Uopt.t 42 | } 43 | [@@deriving fields, sexp_of] 44 | 45 | type 'a internal_observer = 'a t [@@deriving sexp_of] 46 | 47 | let use_is_allowed t = 48 | match t.state with 49 | | Created | In_use -> true 50 | | Disallowed | Unlinked -> false 51 | ;; 52 | 53 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 54 | 55 | let same_as_packed (t1 : _ t) (Packed_.T t2) = same t1 t2 56 | 57 | let invariant invariant_a t = 58 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 59 | let check f = Invariant.check_field t f in 60 | Fields.iter 61 | ~state:ignore 62 | ~observing:(check (Node.invariant invariant_a)) 63 | ~on_update_handlers:(check (fun on_update_handlers -> 64 | match t.state with 65 | | Created | In_use | Disallowed -> () 66 | | Unlinked -> assert (List.is_empty on_update_handlers))) 67 | ~prev_in_all:(check (fun prev_in_all -> 68 | begin match t.state with 69 | | In_use | Disallowed -> () 70 | | Created | Unlinked -> assert (Uopt.is_none prev_in_all) 71 | end; 72 | if Uopt.is_some prev_in_all 73 | then assert (same_as_packed t 74 | (Uopt.value_exn (Packed_.next_in_all 75 | (Uopt.value_exn prev_in_all)))))) 76 | ~next_in_all:(check (fun next_in_all -> 77 | begin match t.state with 78 | | In_use | Disallowed -> () 79 | | Created | Unlinked -> assert (Uopt.is_none next_in_all) 80 | end; 81 | if Uopt.is_some next_in_all 82 | then assert (same_as_packed t 83 | (Uopt.value_exn (Packed_.prev_in_all 84 | (Uopt.value_exn next_in_all)))))) 85 | ~prev_in_observing:(check (fun prev_in_observing -> 86 | begin match t.state with 87 | | In_use | Disallowed -> () 88 | | Created | Unlinked -> assert (Uopt.is_none prev_in_observing) 89 | end; 90 | if Uopt.is_some prev_in_observing 91 | then assert (phys_equal t 92 | (Uopt.value_exn (next_in_observing 93 | (Uopt.value_exn prev_in_observing)))))) 94 | ~next_in_observing:(check (fun next_in_observing -> 95 | begin match t.state with 96 | | In_use | Disallowed -> () 97 | | Created | Unlinked -> assert (Uopt.is_none next_in_observing) 98 | end; 99 | if Uopt.is_some next_in_observing 100 | then assert (phys_equal t 101 | (Uopt.value_exn (prev_in_observing 102 | (Uopt.value_exn next_in_observing)))))) 103 | ) 104 | ;; 105 | 106 | let value_exn t = 107 | match t.state with 108 | | Created -> 109 | failwiths "Observer.value_exn called without stabilizing" t [%sexp_of: _ t]; 110 | | Disallowed | Unlinked -> 111 | failwiths "Observer.value_exn called after disallow_future_use" t [%sexp_of: _ t]; 112 | | In_use -> 113 | let uopt = t.observing.value_opt in 114 | if Uopt.is_none uopt 115 | then failwiths "attempt to get value of an invalid node" t [%sexp_of: _ t]; 116 | Uopt.unsafe_value uopt 117 | ;; 118 | 119 | let on_update_exn t on_update_handler = 120 | match t.state with 121 | | Disallowed | Unlinked -> failwiths "on_update disallowed" t [%sexp_of: _ t] 122 | | Created | In_use -> 123 | t.on_update_handlers <- on_update_handler :: t.on_update_handlers; 124 | match t.state with 125 | | Disallowed | Unlinked -> assert false 126 | | Created -> 127 | (* We'll bump [observing.num_on_update_handlers] when [t] is actually added to 128 | [observing.observers] at the start of the next stabilization. *) 129 | () 130 | | In_use -> 131 | let observing = t.observing in 132 | observing.num_on_update_handlers <- observing.num_on_update_handlers + 1; 133 | ;; 134 | 135 | let unlink_from_observing t = 136 | let prev = t.prev_in_observing in 137 | let next = t.next_in_observing in 138 | t.prev_in_observing <- Uopt.none; 139 | t.next_in_observing <- Uopt.none; 140 | if Uopt.is_some next then (Uopt.unsafe_value next).prev_in_observing <- prev; 141 | if Uopt.is_some prev then (Uopt.unsafe_value prev).next_in_observing <- next; 142 | let observing = t.observing in 143 | if phys_equal t (Uopt.value_exn observing.observers) then observing.observers <- next; 144 | observing.num_on_update_handlers <- 145 | observing.num_on_update_handlers - List.length t.on_update_handlers; 146 | t.on_update_handlers <- []; 147 | ;; 148 | 149 | let unlink_from_all t = 150 | let prev = t.prev_in_all in 151 | let next = t.next_in_all in 152 | t.prev_in_all <- Uopt.none; 153 | t.next_in_all <- Uopt.none; 154 | if Uopt.is_some next then Packed_.set_prev_in_all (Uopt.unsafe_value next) prev; 155 | if Uopt.is_some prev then Packed_.set_next_in_all (Uopt.unsafe_value prev) next; 156 | ;; 157 | 158 | let unlink t = 159 | unlink_from_observing t; 160 | unlink_from_all t; 161 | ;; 162 | 163 | module Packed = struct 164 | 165 | include Packed_ 166 | 167 | let sexp_of_t (T internal_observer) = 168 | internal_observer |> [%sexp_of: _ internal_observer] 169 | ;; 170 | 171 | let invariant (T t) = invariant ignore t 172 | 173 | end 174 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Internal_observer 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 | val same : _ t -> _ t -> bool 16 | 17 | val observing : 'a t -> 'a Node.t 18 | 19 | val use_is_allowed : _ t -> bool 20 | 21 | val value_exn : 'a t -> 'a 22 | 23 | val on_update_exn : 'a t -> 'a On_update_handler.t -> unit 24 | 25 | val unlink : _ t -> unit 26 | 27 | module Packed : sig 28 | type t = Types.Packed_internal_observer.t = T : _ Types.Internal_observer.t -> t 29 | [@@deriving sexp_of] 30 | 31 | include Invariant.S with type t := t 32 | 33 | val next_in_all : t -> t Uopt.t 34 | val set_prev_in_all : t -> t Uopt.t -> unit 35 | end 36 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name incremental_kernel) 3 | (public_name incremental_kernel) 4 | (libraries (core_kernel 5 | core_kernel.uopt)) 6 | (preprocess (pps (ppx_jane -check-doc-comments ppxlib.runner))) 7 | (preprocessor_deps (debug.mlh)) 8 | )) 9 | 10 | 11 | (jbuild_version 1) 12 | -------------------------------------------------------------------------------- /src/join.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type 'a t = 'a Types.Join.t = 8 | { main : 'a Node.t 9 | ; lhs : 'a Node.t Node.t 10 | ; lhs_change : unit Node.t 11 | ; mutable rhs : 'a Node.t Uopt.t 12 | } 13 | [@@deriving fields, sexp_of] 14 | 15 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 16 | 17 | let invariant _invariant_a t = 18 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 19 | let check f = Invariant.check_field t f in 20 | Fields.iter 21 | ~main:(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:(check (fun (lhs_change : _ Node.t) -> 28 | match lhs_change.kind with 29 | | Invalid -> () 30 | | Join_lhs_change t' -> assert (same t t') 31 | | _ -> assert false)) 32 | ~rhs:ignore) 33 | ;; 34 | -------------------------------------------------------------------------------- /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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | include module type of struct include Types.Join end 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | include Sexp_of. S1 with type 'a t := 'a t 13 | -------------------------------------------------------------------------------- /src/kind.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | 4 | module Node = Types.Node 5 | module Packed_node = Types.Packed_node 6 | 7 | type 'a t = 'a Types.Kind.t = 8 | | Array_fold : (_, 'a) Array_fold.t -> 'a t 9 | | At : At.t -> Before_or_after.t t 10 | | At_intervals : At_intervals.t -> unit t 11 | | Bind_lhs_change : (_, _) Bind.t -> unit t 12 | | Bind_main : (_, 'a) Bind.t -> 'a t 13 | | Const of 'a 14 | | Expert of 'a Expert.t 15 | | Freeze of 'a Freeze.t 16 | | If_test_change : _ If_then_else.t -> unit t 17 | | If_then_else of 'a If_then_else.t 18 | | Invalid 19 | | Join_lhs_change : _ Join.t -> unit t 20 | | Join_main of 'a Join.t 21 | | Map : ('a1 -> 'a) * 'a1 Node.t -> 'a t 22 | | Snapshot of 'a Snapshot.t 23 | | Step_function of 'a Step_function.t 24 | | Uninitialized 25 | | Unordered_array_fold : (_, 'a) Unordered_array_fold.t -> 'a t 26 | | Var of 'a Var.t 27 | | Map2 28 | : ('a1 -> 'a2 -> 'a) 29 | * 'a1 Node.t * 'a2 Node.t 30 | -> 'a t 31 | | Map3 32 | : ('a1 -> 'a2 -> 'a3 -> 'a) 33 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t 34 | -> 'a t 35 | | Map4 36 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a) 37 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t 38 | -> 'a t 39 | | Map5 40 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a) 41 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t 42 | -> 'a t 43 | | Map6 44 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a) 45 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 46 | -> 'a t 47 | | Map7 48 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a) 49 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 50 | * 'a7 Node.t 51 | -> 'a t 52 | | Map8 53 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a) 54 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 55 | * 'a7 Node.t * 'a8 Node.t 56 | -> 'a t 57 | | Map9 58 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 -> 'a) 59 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 60 | * 'a7 Node.t * 'a8 Node.t * 'a9 Node.t 61 | -> 'a t 62 | [@@deriving sexp_of] 63 | 64 | let name : type a. a t -> string = function 65 | | Array_fold _ -> "Array_fold" 66 | | At _ -> "At" 67 | | At_intervals _ -> "At_intervals" 68 | | Bind_lhs_change _ -> "Bind_lhs_change" 69 | | Bind_main _ -> "Bind_main" 70 | | Const _ -> "Const" 71 | | Expert _ -> "Expert" 72 | | Freeze _ -> "Freeze" 73 | | If_test_change _ -> "If_test_change" 74 | | If_then_else _ -> "If_then_else" 75 | | Invalid -> "Invalid" 76 | | Join_lhs_change _ -> "Join_lhs_change" 77 | | Join_main _ -> "Join_main" 78 | | Map _ -> "Map" 79 | | Map2 _ -> "Map2" 80 | | Map3 _ -> "Map3" 81 | | Map4 _ -> "Map4" 82 | | Map5 _ -> "Map5" 83 | | Map6 _ -> "Map6" 84 | | Map7 _ -> "Map7" 85 | | Map8 _ -> "Map8" 86 | | Map9 _ -> "Map9" 87 | | Snapshot _ -> "Snapshot" 88 | | Step_function _ -> "Step_function" 89 | | Uninitialized -> "Uninitialized" 90 | | Unordered_array_fold _ -> "Unordered_array_fold" 91 | | Var _ -> "Var" 92 | ;; 93 | 94 | let invariant : type a . a Invariant.t -> a t Invariant.t = fun invariant_a t -> 95 | match t with 96 | | Array_fold array_fold -> Array_fold.invariant ignore invariant_a array_fold 97 | | At at -> At.invariant at 98 | | At_intervals at_intervals -> At_intervals.invariant at_intervals 99 | | Bind_lhs_change bind -> Bind.invariant ignore ignore bind 100 | | Bind_main bind -> Bind.invariant ignore invariant_a bind 101 | | Const a -> invariant_a a 102 | | Expert e -> Expert.invariant invariant_a e 103 | | Freeze freeze -> Freeze.invariant invariant_a freeze 104 | | If_test_change if_then_else -> If_then_else.invariant ignore if_then_else 105 | | If_then_else if_then_else -> If_then_else.invariant invariant_a if_then_else 106 | | Invalid -> () 107 | | Join_lhs_change join -> Join.invariant ignore join 108 | | Join_main join -> Join.invariant invariant_a join 109 | | Map _ -> () 110 | | Map2 _ -> () 111 | | Map3 _ -> () 112 | | Map4 _ -> () 113 | | Map5 _ -> () 114 | | Map6 _ -> () 115 | | Map7 _ -> () 116 | | Map8 _ -> () 117 | | Map9 _ -> () 118 | | Snapshot snapshot -> Snapshot.invariant invariant_a snapshot 119 | | Step_function step_function -> Step_function.invariant invariant_a step_function 120 | | Uninitialized -> () 121 | | Unordered_array_fold unordered_array_fold -> 122 | Unordered_array_fold.invariant ignore invariant_a unordered_array_fold 123 | | Var var -> Var.invariant ignore var 124 | ;; 125 | 126 | let initial_num_children (type a) (t : a t) = 127 | match t with 128 | | At _ -> 0 129 | | At_intervals _ -> 0 130 | | Bind_lhs_change _ -> 1 131 | | Bind_main _ -> 2 132 | | Const _ -> 0 133 | | Expert _ -> 0 134 | | Freeze _ -> 1 135 | | If_test_change _ -> 1 136 | | If_then_else _ -> 2 137 | | Invalid -> 0 138 | | Join_lhs_change _ -> 1 139 | | Join_main _ -> 2 140 | | Map _ -> 1 141 | | Map2 _ -> 2 142 | | Map3 _ -> 3 143 | | Map4 _ -> 4 144 | | Map5 _ -> 5 145 | | Map6 _ -> 6 146 | | Map7 _ -> 7 147 | | Map8 _ -> 8 148 | | Map9 _ -> 9 149 | | Snapshot _ -> 0 150 | | Step_function _ -> 0 151 | | Uninitialized -> 0 152 | | Var _ -> 0 153 | | Array_fold { children; _ } -> Array.length children 154 | | Unordered_array_fold { children; _ } -> Array.length children 155 | ;; 156 | 157 | let bind_rhs_child_index = 1 158 | let freeze_child_index = 0 159 | let if_branch_child_index = 1 160 | let join_rhs_child_index = 1 161 | 162 | (* We do not implement the time-based nodes ([At], [At_intervals], [Snapshot], 163 | [Step_function]) as parents of the current-time node for performance reasons. We don't 164 | want all such nodes to be recomputed whenever the time changes, which would be horribly 165 | inneficient. Instead, we only want them to be recomputed at the "right" time, 166 | i.e. when time passes some threshold relevant to them. We do this via scheduling 167 | alarms at those thresholds. *) 168 | let iteri_children (type a) (t : a t) ~(f : int -> Packed_node.t -> unit) : unit = 169 | match t with 170 | | Array_fold { children; _ } -> 171 | for i = 0 to Array.length children - 1 do 172 | f i (Node.pack (Array.unsafe_get children i)); 173 | done; 174 | | At _ -> () 175 | | At_intervals _ -> () 176 | | Bind_lhs_change bind -> f 0 (Node.pack bind.lhs) 177 | | Bind_main { lhs_change; rhs; _ } -> 178 | (* Various code, e.g. [state.became_necessary], relies on processing [lhs_change] 179 | before [rhs]. *) 180 | f 0 (Node.pack lhs_change); 181 | if Uopt.is_some rhs then f 1 (Node.pack (Uopt.unsafe_value rhs)); 182 | | Const _ -> () 183 | | Expert { children; num_children; _ } -> 184 | for i = 0 to num_children - 1; do 185 | let Expert.E r = Uopt.value_exn (Array.unsafe_get children i) in 186 | f i (Node.pack r.child) 187 | done 188 | | Freeze { child; _ } -> f 0 (Node.pack child) 189 | | If_test_change { test; _ } -> f 0 (Node.pack test) 190 | | If_then_else { test_change; current_branch; _ } -> 191 | f 0 (Node.pack test_change); 192 | if Uopt.is_some current_branch then f 1 (Node.pack (Uopt.unsafe_value current_branch)); 193 | | Invalid -> () 194 | | Join_lhs_change { lhs; _ } -> f 0 (Node.pack lhs) 195 | | Join_main { lhs_change; rhs; _ } -> 196 | f 0 (Node.pack lhs_change); 197 | if Uopt.is_some rhs then f 1 (Node.pack (Uopt.unsafe_value rhs)); 198 | | Snapshot _ -> () 199 | | Step_function _ -> () 200 | | Uninitialized -> () 201 | | Unordered_array_fold { children; _ } -> 202 | for i = 0 to Array.length children - 1 do 203 | f i (Node.pack (Array.unsafe_get children i)); 204 | done; 205 | | Var _ -> () 206 | | Map (_, node0) -> 207 | f 0 (Node.pack node0) 208 | | Map2 (_, node0, node1) -> 209 | f 0 (Node.pack node0); 210 | f 1 (Node.pack node1); 211 | | Map3 (_, node0, node1, node2) -> 212 | f 0 (Node.pack node0); 213 | f 1 (Node.pack node1); 214 | f 2 (Node.pack node2); 215 | | Map4 (_, node0, node1, node2, node3) -> 216 | f 0 (Node.pack node0); 217 | f 1 (Node.pack node1); 218 | f 2 (Node.pack node2); 219 | f 3 (Node.pack node3); 220 | | Map5 (_, node0, node1, node2, node3, node4) -> 221 | f 0 (Node.pack node0); 222 | f 1 (Node.pack node1); 223 | f 2 (Node.pack node2); 224 | f 3 (Node.pack node3); 225 | f 4 (Node.pack node4); 226 | | Map6 (_, node0, node1, node2, node3, node4, node5) -> 227 | f 0 (Node.pack node0); 228 | f 1 (Node.pack node1); 229 | f 2 (Node.pack node2); 230 | f 3 (Node.pack node3); 231 | f 4 (Node.pack node4); 232 | f 5 (Node.pack node5); 233 | | Map7 (_, node0, node1, node2, node3, node4, node5, node6) -> 234 | f 0 (Node.pack node0); 235 | f 1 (Node.pack node1); 236 | f 2 (Node.pack node2); 237 | f 3 (Node.pack node3); 238 | f 4 (Node.pack node4); 239 | f 5 (Node.pack node5); 240 | f 6 (Node.pack node6); 241 | | Map8 (_, node0, node1, node2, node3, node4, node5, node6, node7) -> 242 | f 0 (Node.pack node0); 243 | f 1 (Node.pack node1); 244 | f 2 (Node.pack node2); 245 | f 3 (Node.pack node3); 246 | f 4 (Node.pack node4); 247 | f 5 (Node.pack node5); 248 | f 6 (Node.pack node6); 249 | f 7 (Node.pack node7); 250 | | Map9 (_, node0, node1, node2, node3, node4, node5, node6, node7, node8) -> 251 | f 0 (Node.pack node0); 252 | f 1 (Node.pack node1); 253 | f 2 (Node.pack node2); 254 | f 3 (Node.pack node3); 255 | f 4 (Node.pack node4); 256 | f 5 (Node.pack node5); 257 | f 6 (Node.pack node6); 258 | f 7 (Node.pack node7); 259 | f 8 (Node.pack node8); 260 | ;; 261 | 262 | (* [slow_get_child] is only used by [Node.invariant], so we don't mind using [with_return] 263 | and [iteri_children]. If we ever need a fast [get_child], we coded it in rev 264 | 48dbfd03c9c5. *) 265 | let slow_get_child : type a . a t -> index:_ -> _ = 266 | fun t ~index -> 267 | match t with 268 | | Array_fold { children; _ } -> Node.pack children.( index ) 269 | | Unordered_array_fold { children; _ } -> Node.pack children.( index ) 270 | | Expert { children; _ } -> 271 | let Expert.E edge = Uopt.value_exn children.( index ) in 272 | Node.pack edge.child 273 | | _ -> 274 | with_return (fun r -> 275 | iteri_children t ~f:(fun i child -> if i = index then r.return child); 276 | failwiths "Kind.slow_get_child got invalid index" (index, t) 277 | [%sexp_of: int * _ t]); 278 | ;; 279 | -------------------------------------------------------------------------------- /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_kernel 7 | open! Import 8 | 9 | include module type of struct include Types.Kind end 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 name : _ t -> string 15 | 16 | val initial_num_children : _ t -> int 17 | 18 | (** [slow_get_child t ~index] raises unless [0 <= index < max_num_children t]. It will 19 | also raise if the [index]'th child is currently undefined (e.g. a bind node with no 20 | current rhs). *) 21 | val slow_get_child : _ t -> index:int -> Types.Packed_node.t 22 | 23 | val bind_rhs_child_index : int 24 | val freeze_child_index : int 25 | val if_branch_child_index : int 26 | val join_rhs_child_index : int 27 | 28 | val iteri_children : _ t -> f:(int -> Types.Packed_node.t -> unit) -> unit 29 | -------------------------------------------------------------------------------- /src/node.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | open Kind 4 | 5 | module Internal_observer = Types.Internal_observer 6 | module Node = Types.Node 7 | module Packed_node = Types.Packed_node 8 | 9 | type 'a t = 'a Types.Node.t = 10 | { (* [id] is a unique id for the node. *) 11 | id : Node_id.t 12 | (* The fields from [recomputed_at] to [created_in] are grouped together and are in the 13 | same order as they are used by [State.recompute] This has a positive performance 14 | impact due to cache effects. Don't change the order of these nodes without 15 | performance testing. *) 16 | (* [recomputed_at] is the last stabilization when [t]'s value was recomputed, even if it 17 | was cut off. *) 18 | ; mutable recomputed_at : Stabilization_num.t 19 | (* [value_opt] starts as [none], and the first time [t] is computed it is set to [some], 20 | and remains [some] thereafter, until [t] is invalidated, if ever. *) 21 | ; mutable value_opt : 'a Uopt.t 22 | (* [kind] is the kind of DAG node [t] is. [kind] is mutable both for initialization and 23 | because it can change, e.g. if [t] is invalidated. *) 24 | ; mutable kind : 'a Kind.t 25 | ; mutable cutoff : 'a Cutoff.t 26 | (* [changed_at] is the last stabilization when this node was computed and not cut off. 27 | It is used to detect when [t]'s parents are stale and (because all parents are 28 | necessary) need to be recomputed. *) 29 | ; mutable changed_at : Stabilization_num.t 30 | (* [num_on_update_handlers] is [List.length t.on_update_handlers] plus the number of 31 | on-update handlers summed over all observers in [t.observers]. It is used to quickly 32 | decide whether [t] needs to be added to [state.handle_after_stabilization] when [t] 33 | changes. [num_on_update_handlers] will decrease when an observer is removed from 34 | [t.observers], if the observer has on-update handlers. *) 35 | ; mutable num_on_update_handlers : int 36 | (* The parents of [t] are the nodes that depend on it, and should be computed when [t] 37 | changes, once all of their other children are up to date. [num_parents] is the 38 | number of parents. If [num_parents >= 1], then [parent0] is the first parent. 39 | [parent1_and_beyond] holds the remaining parents. The order of the parents doesn't 40 | matter. One node may occur multiple times as a parent of another (e.g. consider 41 | [map2 n1 n1 ~f]). 42 | 43 | This representation is optimized for the overwhelmingly common case that a node has 44 | only one parent. *) 45 | ; mutable num_parents : int 46 | ; mutable parent1_and_beyond : Packed_node.t Uopt.t array 47 | ; mutable parent0 : Packed_node.t Uopt.t 48 | (* [created_in] is initially the scope that the node is created in. If a node is later 49 | "rescoped", then created_in will be adjusted to the new scope that the node is part 50 | of. *) 51 | ; mutable created_in : Scope.t 52 | (* [next_node_in_same_scope] singly links all nodes created in [t.created_in]. *) 53 | ; mutable next_node_in_same_scope : Packed_node.t Uopt.t 54 | (* [height] is used to visit nodes in topological order. If [is_necessary t], then 55 | [height > c.height] for all children [c] of [t], and [height > Scope.height 56 | t.created_in]. If [not (is_necessary t)], then [height = -1]. *) 57 | ; mutable height : int 58 | (* [height_in_recompute_heap] is the height at which [t] is stored in the recompute 59 | heap, and is non-negative iff [t] is in the recompute heap. If [t] is the recompute 60 | heap, then typically [t.height = t.height_in_recompute_heap]; however, while height 61 | is being adjusted, one can temporarily have [t.height > t.height_in_recompute_heap]. 62 | When height adjustment finishes, equality is restored by increasing 63 | [t.height_in_recompute_heap] to [t.height] and shifting [t]'s position in the 64 | recompute heap. *) 65 | ; mutable height_in_recompute_heap : int 66 | (* [prev_in_recompute_heap] and [next_in_recompute_heap] doubly link all nodes of the 67 | same height in the recompute heap. *) 68 | ; mutable prev_in_recompute_heap : Packed_node.t Uopt.t 69 | ; mutable next_in_recompute_heap : Packed_node.t Uopt.t 70 | (* [height_in_adjust_heights_heap] is used only during height adjustment, and is 71 | non-negative iff [t] is in the adjust-heights heap. It holds the pre-adjusted height 72 | of [t]. *) 73 | ; mutable height_in_adjust_heights_heap : int 74 | (* [next_in_adjust_heights_heap] singly links all nodes of the same height in the 75 | adjust-heights heap. *) 76 | ; mutable next_in_adjust_heights_heap : Packed_node.t Uopt.t 77 | (* [old_value_opt] is used only during stabilization, and only if 78 | [t.num_on_update_handlers > 0]. It holds the pre-stabilization value of [t]. It is 79 | cleared when running [t]'s on-update handlers, and so is always [Uopt.none] between 80 | stabilizations. *) 81 | ; mutable old_value_opt : 'a Uopt.t 82 | (* [observers] is the head of the doubly-linked list of observers of [t], or [Uopt.none] 83 | if there are no observers. *) 84 | ; mutable observers : 'a Internal_observer.t sexp_opaque Uopt.t 85 | (* [is_in_handle_after_stabilization] is used to avoid pushing the same node multiple 86 | times onto [state.handle_after_stabilization]. *) 87 | ; mutable is_in_handle_after_stabilization : bool 88 | (* [on_update_handlers] is the functions supplied to [Incremental.on_update] to be run 89 | as described in the module [On_update_handler]. [on_update_handlers] does not 90 | contain the on-update handlers in [t.observers]. [on_update_handlers] only ever gets 91 | longer; there is no way to remove elements. *) 92 | ; mutable on_update_handlers : 'a On_update_handler.t list 93 | ; mutable my_parent_index_in_child_at_index : int array 94 | ; mutable my_child_index_in_parent_at_index : int array 95 | ; mutable force_necessary : bool 96 | ; mutable user_info : Info.t option 97 | ; creation_backtrace : Backtrace.t option 98 | } 99 | [@@deriving fields, sexp_of] 100 | 101 | let same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 102 | 103 | let pack (type a) t = (Obj.magic (t : a t) : Should_not_use.t t) 104 | 105 | let set_user_info t user_info = t.user_info <- user_info 106 | 107 | let is_necessary = Node.is_necessary 108 | 109 | let initial_num_children t = Kind.initial_num_children t.kind 110 | 111 | let iteri_children t ~f = Kind.iteri_children t.kind ~f 112 | 113 | let is_valid = Node.is_valid 114 | 115 | let edge_is_stale ~child ~parent = 116 | Stabilization_num.compare child.changed_at parent.recomputed_at > 0 117 | ;; 118 | 119 | let is_stale_with_respect_to_a_child t = 120 | let is_stale = ref false in 121 | iteri_children t ~f:(fun _ child -> 122 | if edge_is_stale ~child ~parent:t then is_stale := true); 123 | !is_stale 124 | ;; 125 | 126 | let is_stale : type a. a t -> bool = fun (t : a t) -> 127 | match t.kind with 128 | | Uninitialized -> assert false 129 | (* A const node is stale only at initialization. *) 130 | | Const _ -> Stabilization_num.is_none t.recomputed_at 131 | (* Time-based nodes are considered stale when [t.recomputed_at] is none, which happens 132 | at initialization and when the alarm mechanism makes a node stale (it sets the 133 | [t.recomputed_at] to [Stabilization_num.none]). *) 134 | | At _ -> Stabilization_num.is_none t.recomputed_at 135 | | At_intervals _ -> Stabilization_num.is_none t.recomputed_at 136 | | Snapshot _ -> Stabilization_num.is_none t.recomputed_at 137 | | Step_function _ -> Stabilization_num.is_none t.recomputed_at 138 | (* We never consider an invalidated node to be stale -- when we invalidate a node, we 139 | immediately propagate invalidity to its ancestors. *) 140 | | Invalid -> false 141 | (* A [Var] node is stale if it was set since it was recomputed. *) 142 | | Var { set_at; _ } -> Stabilization_num.compare set_at t.recomputed_at > 0 143 | (* Nodes that have children. *) 144 | | Bind_lhs_change _ -> 145 | Stabilization_num.is_none t.recomputed_at 146 | || is_stale_with_respect_to_a_child t 147 | | If_test_change _ -> 148 | Stabilization_num.is_none t.recomputed_at 149 | || is_stale_with_respect_to_a_child t 150 | | Join_lhs_change _ -> 151 | Stabilization_num.is_none t.recomputed_at 152 | || is_stale_with_respect_to_a_child t 153 | | Array_fold _ 154 | | Bind_main _ 155 | | Freeze _ 156 | | If_then_else _ 157 | | Join_main _ 158 | | Map _ 159 | | Map2 _ 160 | | Map3 _ 161 | | Map4 _ 162 | | Map5 _ 163 | | Map6 _ 164 | | Map7 _ 165 | | Map8 _ 166 | | Map9 _ 167 | | Unordered_array_fold _ 168 | -> 169 | Stabilization_num.is_none t.recomputed_at 170 | || is_stale_with_respect_to_a_child t 171 | | Expert { force_stale; _ } -> 172 | force_stale 173 | || Stabilization_num.is_none t.recomputed_at 174 | || is_stale_with_respect_to_a_child t 175 | ;; 176 | 177 | let needs_to_be_computed t = is_necessary t && is_stale t 178 | 179 | let is_in_recompute_heap t = t.height_in_recompute_heap >= 0 180 | 181 | let is_in_adjust_heights_heap t = t.height_in_adjust_heights_heap >= 0 182 | 183 | let get_parent t ~index = 184 | Uopt.value_exn 185 | (if index = 0 186 | then t.parent0 187 | else t.parent1_and_beyond.( index - 1 )) 188 | ;; 189 | 190 | let iteri_parents t ~f = 191 | if t.num_parents > 0 then begin 192 | f 0 (Uopt.value_exn t.parent0); 193 | for index = 1 to t.num_parents - 1 do 194 | f index (Uopt.value_exn t.parent1_and_beyond.( index - 1 )); 195 | done; 196 | end; 197 | ;; 198 | 199 | let has_child t ~child = 200 | let has = ref false in 201 | iteri_children t ~f:(fun _ child' -> has := !has || same child child'); 202 | !has 203 | ;; 204 | 205 | let has_invalid_child t = 206 | let has = ref false in 207 | iteri_children t ~f:(fun _ child -> has := !has || not (is_valid child)); 208 | !has 209 | ;; 210 | 211 | let has_parent t ~parent = 212 | let has = ref false in 213 | iteri_parents t ~f:(fun _ parent' -> has := !has || same parent parent'); 214 | !has 215 | ;; 216 | 217 | let should_be_invalidated : type a. a t -> bool = fun t -> 218 | match t.kind with 219 | (* nodes with no children *) 220 | | Uninitialized -> assert false 221 | | At _ -> false 222 | | At_intervals _ -> false 223 | | Const _ 224 | | Snapshot _ 225 | | Step_function _ 226 | | Var _ 227 | -> false 228 | | Invalid -> false 229 | (* Nodes with a fixed set of children are invalid if any child is invalid. *) 230 | | Array_fold _ 231 | | Freeze _ 232 | | Map _ | Map2 _ | Map3 _ | Map4 _ | Map5 _ | Map6 _ | Map7 _ | Map8 _ | Map9 _ 233 | | Unordered_array_fold _ 234 | -> has_invalid_child t 235 | (* A *_change node is invalid if the node it is watching for changes is invalid (same 236 | reason as above). This is equivalent to [has_invalid_child t]. *) 237 | | Bind_lhs_change { lhs; _ } -> not (is_valid lhs) 238 | | If_test_change { test; _ } -> not (is_valid test) 239 | | Join_lhs_change { lhs; _ } -> not (is_valid lhs) 240 | (* [Bind_main], [If_then_else], and [Join_main] are invalid if their *_change child is, 241 | but not necessarily if their other children are -- the graph may be restructured to 242 | avoid the invalidity of those. *) 243 | | Bind_main { lhs_change; _ } -> not (is_valid lhs_change) 244 | | If_then_else { test_change; _ } -> not (is_valid test_change) 245 | | Join_main { lhs_change; _ } -> not (is_valid lhs_change) 246 | | Expert _ -> 247 | (* This is similar to what we do for bind above, except that any invalid child can be 248 | removed, so we can only tell if an expert node becomes invalid when all its 249 | dependencies have fired (which in practice means when we are about to run it). *) 250 | false 251 | ;; 252 | 253 | let fold_observers t ~init ~f = 254 | let r = ref t.observers in 255 | let ac = ref init in 256 | while Uopt.is_some !r do 257 | let observer = Uopt.value_exn !r in 258 | r := observer.next_in_observing; 259 | ac := f !ac observer; 260 | done; 261 | !ac 262 | ;; 263 | 264 | let iter_observers t ~f = fold_observers t ~init:() ~f:(fun () observer -> f observer) 265 | 266 | let invariant (type a) (invariant_a : a -> unit) (t : a t) = 267 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 268 | [%test_eq: bool] (needs_to_be_computed t) (is_in_recompute_heap t); 269 | if is_necessary t then begin 270 | assert (t.height > Scope.height t.created_in); 271 | iteri_children t ~f:(fun _ child -> 272 | assert (t.height > child.height); 273 | assert (has_parent child ~parent:t)); 274 | assert (not (should_be_invalidated t)); 275 | end; 276 | iteri_parents t ~f:(fun _ parent -> 277 | assert (has_child parent ~child:t); 278 | assert (is_necessary parent); 279 | assert (t.height < parent.height)); 280 | let check f = Invariant.check_field t f in 281 | Fields.iter 282 | ~id:(check Node_id.invariant) 283 | ~recomputed_at:(check Stabilization_num.invariant) 284 | ~value_opt:(check (fun value_opt -> 285 | if is_valid t && not (is_stale t) then assert (Uopt.is_some value_opt); 286 | Uopt.invariant invariant_a value_opt)) 287 | ~kind:(check (fun kind -> 288 | Kind.invariant invariant_a kind; 289 | match kind with 290 | | Expert e -> 291 | Expert.invariant_about_num_invalid_children e 292 | ~is_necessary:(is_necessary t) 293 | | _ -> ())) 294 | ~cutoff:(check (Cutoff.invariant invariant_a)) 295 | ~changed_at:(check (fun changed_at -> 296 | Stabilization_num.invariant changed_at; 297 | if Stabilization_num.is_some t.recomputed_at 298 | then assert (Stabilization_num.compare changed_at t.recomputed_at <= 0))) 299 | ~num_on_update_handlers: 300 | (check 301 | ([%test_result: int] 302 | ~expect:(List.length t.on_update_handlers 303 | + fold_observers t ~init:0 304 | ~f:(fun n { on_update_handlers; _ } -> 305 | n + List.length on_update_handlers)))) 306 | ~num_parents:(check (fun num_parents -> 307 | assert (num_parents >= 0); 308 | assert (num_parents <= 1 + Array.length t.parent1_and_beyond))) 309 | ~parent1_and_beyond:(check (fun parent1_and_beyond -> 310 | for parent_index = 1 to Array.length parent1_and_beyond do 311 | [%test_eq: bool] 312 | (parent_index < t.num_parents) 313 | (Uopt.is_some parent1_and_beyond.( parent_index - 1 )); 314 | done)) 315 | ~parent0:(check (fun parent0 -> 316 | [%test_eq: bool] (t.num_parents > 0) (Uopt.is_some parent0))) 317 | ~created_in:(check Scope.invariant) 318 | ~next_node_in_same_scope:(check (fun next_node_in_same_scope -> 319 | if Scope.is_top t.created_in || not (is_valid t) 320 | then assert (Uopt.is_none next_node_in_same_scope))) 321 | ~height:(check (fun height -> 322 | if is_necessary t 323 | then assert (height >= 0) 324 | else assert (height = -1))) 325 | ~height_in_recompute_heap:(check (fun height_in_recompute_heap -> 326 | assert (height_in_recompute_heap >= -1); 327 | assert (height_in_recompute_heap <= t.height))) 328 | ~prev_in_recompute_heap:(check (fun prev_in_recompute_heap -> 329 | if not (is_in_recompute_heap t) then assert (Uopt.is_none prev_in_recompute_heap); 330 | if Uopt.is_some prev_in_recompute_heap then begin 331 | let prev = Uopt.value_exn prev_in_recompute_heap in 332 | assert (same t (Uopt.value_exn prev.next_in_recompute_heap)); 333 | assert (t.height_in_recompute_heap = prev.height_in_recompute_heap); 334 | end)) 335 | ~next_in_recompute_heap:(check (fun next_in_recompute_heap -> 336 | if not (is_in_recompute_heap t) then assert (Uopt.is_none next_in_recompute_heap); 337 | if Uopt.is_some next_in_recompute_heap then begin 338 | let next = Uopt.value_exn next_in_recompute_heap in 339 | assert (same t (Uopt.value_exn next.prev_in_recompute_heap)); 340 | assert (t.height_in_recompute_heap = next.height_in_recompute_heap); 341 | end)) 342 | ~height_in_adjust_heights_heap:(check (fun height_in_adjust_heights_heap -> 343 | if height_in_adjust_heights_heap >= 0 344 | then assert (height_in_adjust_heights_heap < t.height))) 345 | ~next_in_adjust_heights_heap:(check (fun next_in_adjust_heights_heap -> 346 | if not (is_in_adjust_heights_heap t) 347 | then assert (Uopt.is_none next_in_adjust_heights_heap) 348 | else if Uopt.is_some next_in_adjust_heights_heap then begin 349 | let next = Uopt.value_exn next_in_adjust_heights_heap in 350 | assert (is_in_adjust_heights_heap next); 351 | assert (t.height_in_adjust_heights_heap = next.height_in_adjust_heights_heap); 352 | end)) 353 | ~old_value_opt:(check (Uopt.invariant invariant_a)) 354 | ~observers:(check (fun _ -> 355 | iter_observers t ~f:(fun { state; observing; _ } -> 356 | assert (phys_equal t observing); 357 | match state with 358 | | In_use | Disallowed -> () 359 | | Created | Unlinked -> assert false))) 360 | ~is_in_handle_after_stabilization:ignore 361 | ~on_update_handlers:ignore 362 | ~user_info:ignore 363 | ~my_parent_index_in_child_at_index:(check (fun my_parent_index_in_child_at_index -> 364 | begin match t.kind with 365 | | Expert _ -> () 366 | | _ -> 367 | [%test_result: int] (Array.length my_parent_index_in_child_at_index) 368 | ~expect:(initial_num_children t); 369 | end; 370 | if is_necessary t 371 | then 372 | iteri_children t ~f:(fun child_index child -> 373 | assert (same t (get_parent child 374 | ~index:(my_parent_index_in_child_at_index.( child_index )))) 375 | ))) 376 | ~my_child_index_in_parent_at_index:(check (fun my_child_index_in_parent_at_index -> 377 | [%test_result: int] (Array.length my_child_index_in_parent_at_index) 378 | ~expect:(Array.length t.parent1_and_beyond + 1); 379 | iteri_parents t ~f:(fun parent_index parent -> 380 | assert (same t 381 | (Kind.slow_get_child parent.kind 382 | ~index:(my_child_index_in_parent_at_index.( parent_index ))))))) 383 | ~force_necessary:ignore 384 | ~creation_backtrace:ignore 385 | ) 386 | ;; 387 | 388 | let unsafe_value t = Uopt.unsafe_value t.value_opt 389 | 390 | let value_exn t = 391 | if Uopt.is_some t.value_opt 392 | then Uopt.unsafe_value t.value_opt 393 | else failwiths "attempt to get value of an invalid node" t [%sexp_of: _ t] 394 | ;; 395 | 396 | let get_cutoff t = t.cutoff 397 | let set_cutoff t cutoff = t.cutoff <- cutoff 398 | 399 | let is_const t = 400 | match t.kind with 401 | | Const _ -> true 402 | | _ -> false 403 | ;; 404 | 405 | let on_update t on_update_handler = 406 | t.on_update_handlers <- on_update_handler :: t.on_update_handlers; 407 | t.num_on_update_handlers <- t.num_on_update_handlers + 1; 408 | ;; 409 | 410 | let run_on_update_handlers t node_update ~now = 411 | if verbose then Debug.ams [%here] "run_on_update_handlers" t [%sexp_of: _ t]; 412 | let r = ref t.on_update_handlers in 413 | while not (List.is_empty !r) do 414 | match !r with 415 | | [] -> assert false 416 | | on_update_handler :: rest -> 417 | r := rest; 418 | On_update_handler.run on_update_handler node_update ~now; 419 | done; 420 | let r = ref t.observers in 421 | while Uopt.is_some !r do 422 | let observer = Uopt.value_exn !r in 423 | r := observer.next_in_observing; 424 | let r = ref observer.on_update_handlers in 425 | while not (List.is_empty !r) do 426 | match !r with 427 | | [] -> assert false 428 | | on_update_handler :: rest -> 429 | r := rest; 430 | (* We have to test [state] before each on-update handler, because an on-update 431 | handler might disable its own observer, which should prevent other on-update 432 | handlers in the same observer from running. *) 433 | match observer.state with 434 | | Created | Unlinked -> assert false 435 | | Disallowed -> () 436 | | In_use -> On_update_handler.run on_update_handler node_update ~now 437 | done; 438 | done; 439 | ;; 440 | 441 | let keep_node_creation_backtrace = ref false 442 | 443 | let set_kind t kind = 444 | t.kind <- kind; 445 | t.my_parent_index_in_child_at_index <- 446 | Array.create ~len:(Kind.initial_num_children kind) (-1) 447 | ;; 448 | 449 | let create created_in kind = 450 | let t = 451 | { id = Node_id.next () 452 | ; recomputed_at = Stabilization_num.none 453 | ; value_opt = Uopt.none 454 | ; kind 455 | ; cutoff = Cutoff.phys_equal 456 | ; changed_at = Stabilization_num.none 457 | ; num_on_update_handlers = 0 458 | ; num_parents = 0 459 | ; parent1_and_beyond = [||] 460 | ; parent0 = Uopt.none 461 | ; created_in 462 | ; next_node_in_same_scope = Uopt.none 463 | ; height = -1 464 | ; height_in_recompute_heap = -1 465 | ; prev_in_recompute_heap = Uopt.none 466 | ; next_in_recompute_heap = Uopt.none 467 | ; height_in_adjust_heights_heap = -1 468 | ; next_in_adjust_heights_heap = Uopt.none 469 | ; old_value_opt = Uopt.none 470 | ; observers = Uopt.none 471 | ; is_in_handle_after_stabilization = false 472 | ; on_update_handlers = [] 473 | ; my_parent_index_in_child_at_index = 474 | Array.create ~len:(Kind.initial_num_children kind) (-1) 475 | (* [my_child_index_in_parent_at_index] has one element because it may need to hold 476 | the child index of [parent0]. *) 477 | ; my_child_index_in_parent_at_index = [| -1 |] 478 | ; force_necessary = false 479 | ; user_info = None 480 | ; creation_backtrace = (if !keep_node_creation_backtrace 481 | then Some (Backtrace.get ()) 482 | else None) 483 | } 484 | in 485 | if verbose then Debug.ams [%here] "created node" t [%sexp_of: _ t]; 486 | Scope.add_node created_in t; 487 | (* [invariant] does not yet hold here because many uses of [Node.create] use [kind = 488 | Uninitialized], and then mutate [t.kind] later. *) 489 | t 490 | ;; 491 | 492 | let max_num_parents t = 1 + Array.length t.parent1_and_beyond 493 | 494 | let make_space_for_parent_if_necessary t = 495 | if t.num_parents = max_num_parents t then begin 496 | let new_max_num_parents = 2 * max_num_parents t in 497 | t.parent1_and_beyond <- 498 | Array.realloc t.parent1_and_beyond ~len:(new_max_num_parents - 1) Uopt.none; 499 | t.my_child_index_in_parent_at_index <- 500 | Array.realloc t.my_child_index_in_parent_at_index ~len:new_max_num_parents (-1); 501 | end; 502 | if debug then assert (t.num_parents < max_num_parents t); 503 | ;; 504 | 505 | let make_space_for_child_if_necessary t ~child_index = 506 | let max_num_children = Array.length t.my_parent_index_in_child_at_index in 507 | if child_index >= max_num_children then begin 508 | if debug then assert (child_index = max_num_children); 509 | let new_max_num_children = Int.max 2 (2 * max_num_children) in 510 | t.my_parent_index_in_child_at_index <- 511 | Array.realloc t.my_parent_index_in_child_at_index ~len:new_max_num_children (-1); 512 | end; 513 | if debug then assert (child_index < Array.length t.my_parent_index_in_child_at_index); 514 | ;; 515 | 516 | let set_parent 517 | : type a . child:a t -> parent:Packed_node.t Uopt.t -> parent_index:int -> unit = 518 | fun ~child ~parent ~parent_index -> 519 | if parent_index = 0 520 | then child.parent0 <- parent 521 | else child.parent1_and_beyond.( parent_index - 1 ) <- parent; 522 | ;; 523 | 524 | let link 525 | : type a b. child:a t -> child_index:int -> parent:b t -> parent_index:int -> unit = 526 | fun ~child ~child_index ~parent ~parent_index -> 527 | set_parent ~child ~parent:(Uopt.some (Node.pack parent)) ~parent_index; 528 | child.my_child_index_in_parent_at_index.( parent_index ) <- child_index; 529 | parent.my_parent_index_in_child_at_index.( child_index ) <- parent_index; 530 | ;; 531 | 532 | let unlink 533 | : type a b. child:a t -> child_index:int -> parent:b t -> parent_index:int -> unit = 534 | fun ~child ~child_index ~parent ~parent_index -> 535 | set_parent ~child ~parent:Uopt.none ~parent_index; 536 | if debug then begin 537 | child.my_child_index_in_parent_at_index.( parent_index ) <- -1; 538 | parent.my_parent_index_in_child_at_index.( child_index ) <- -1; 539 | end; 540 | ;; 541 | 542 | let add_parent 543 | : type a b. child:a t -> parent:b t -> child_index:int -> unit = 544 | fun ~child ~parent ~child_index -> 545 | make_space_for_parent_if_necessary child; 546 | make_space_for_child_if_necessary parent ~child_index; 547 | link ~child ~child_index ~parent ~parent_index:child.num_parents; 548 | child.num_parents <- child.num_parents + 1; 549 | ;; 550 | 551 | let remove_parent 552 | : type a b. child:a t -> parent:b t -> child_index:int -> unit = 553 | fun ~child ~parent ~child_index -> 554 | if verbose 555 | then Debug.ams [%here] "remove_parent" (`child child, `parent parent) 556 | [%sexp_of: [ `child of _ t ] * [ `parent of _ t ]]; 557 | if debug then assert (child.num_parents >= 1); 558 | let parent_index = parent.my_parent_index_in_child_at_index.( child_index ) in 559 | if debug then assert (same parent (get_parent child ~index:parent_index)); 560 | let last_parent_index = child.num_parents - 1 in 561 | if parent_index < last_parent_index then 562 | link 563 | ~child 564 | ~child_index:(child.my_child_index_in_parent_at_index.( last_parent_index )) 565 | ~parent:(Uopt.value_exn child.parent1_and_beyond.( last_parent_index - 1 )) 566 | ~parent_index; 567 | unlink ~child ~child_index ~parent ~parent_index:last_parent_index; 568 | child.num_parents <- child.num_parents - 1; 569 | ;; 570 | 571 | let swap_children_except_in_kind parent ~child1 ~child_index1 ~child2 ~child_index2 = 572 | if debug then begin 573 | assert (same child1 (Kind.slow_get_child parent.kind ~index:child_index1)); 574 | assert (same child2 (Kind.slow_get_child parent.kind ~index:child_index2)); 575 | end; 576 | let index_of_parent_in_child1 = 577 | parent.my_parent_index_in_child_at_index.( child_index1 ) 578 | in 579 | let index_of_parent_in_child2 = 580 | parent.my_parent_index_in_child_at_index.( child_index2 ) 581 | in 582 | if debug then begin 583 | assert (child1.my_child_index_in_parent_at_index.( index_of_parent_in_child1 ) 584 | = child_index1); 585 | assert (child2.my_child_index_in_parent_at_index.( index_of_parent_in_child2 ) 586 | = child_index2); 587 | end; 588 | (* now start swapping *) 589 | child1.my_child_index_in_parent_at_index.( index_of_parent_in_child1 ) <- child_index2; 590 | child2.my_child_index_in_parent_at_index.( index_of_parent_in_child2 ) <- child_index1; 591 | parent.my_parent_index_in_child_at_index.( child_index1 ) <- index_of_parent_in_child2; 592 | parent.my_parent_index_in_child_at_index.( child_index2 ) <- index_of_parent_in_child1; 593 | ;; 594 | 595 | module Packed = struct 596 | 597 | type t = Packed_node.t 598 | 599 | let sexp_of_t t = t |> [%sexp_of: _ t] 600 | 601 | let invariant t = invariant ignore t 602 | 603 | module As_list 604 | (M : sig 605 | val next : Packed_node.t -> Packed_node.t Uopt.t 606 | end) = struct 607 | 608 | type t = Packed_node.t Uopt.t 609 | 610 | let fold t ~init ~f = 611 | let ac = ref init in 612 | let r = ref t in 613 | while Uopt.is_some !r do 614 | let packed_node = Uopt.unsafe_value !r in 615 | r := M.next packed_node; 616 | ac := f !ac packed_node; 617 | done; 618 | !ac 619 | ;; 620 | 621 | let iter t ~f = fold t ~init:() ~f:(fun () n -> f n) 622 | 623 | let invariant t = iter t ~f:invariant 624 | 625 | let length t = fold t ~init:0 ~f:(fun n _ -> n + 1) 626 | 627 | let to_list t = List.rev (fold t ~init:[] ~f:(fun ac n -> n :: ac)) 628 | 629 | let sexp_of_t t = to_list t |> [%sexp_of: Packed_node.t list] 630 | 631 | end 632 | 633 | let iter_descendants_internal ts ~f = 634 | let seen = Node_id.Hash_set.create () in 635 | let rec iter_descendants t = 636 | if not (Hash_set.mem seen t.id) then begin 637 | Hash_set.add seen t.id; 638 | f t; 639 | iteri_children t ~f:(fun _ t -> iter_descendants t); 640 | end; 641 | in 642 | List.iter ts ~f:iter_descendants; 643 | seen; 644 | ;; 645 | 646 | let iter_descendants ts ~f = 647 | ignore (iter_descendants_internal ts ~f : _ Hash_set.t) 648 | ;; 649 | 650 | let save_dot file ts = 651 | Out_channel.with_file file ~f:(fun out -> 652 | let node_name node = "n" ^ Node_id.to_string node.id in 653 | fprintf out "digraph G {\n"; 654 | fprintf out " rankdir = BT\n"; 655 | let bind_edges = ref [] in 656 | let seen = 657 | iter_descendants_internal ts ~f:(fun t -> 658 | let name = node_name t in 659 | fprintf out " %s [label=\"%s %s\\nheight = %d\"]\n" 660 | name name (Kind.name t.kind) t.height; 661 | iteri_children t ~f:(fun _ from_ -> 662 | fprintf out " %s -> %s\n" (node_name from_) name); 663 | begin match t.kind with 664 | | Bind_lhs_change bind -> 665 | Bind.iter_nodes_created_on_rhs bind ~f:(fun to_ -> 666 | bind_edges := (t, to_) :: !bind_edges); 667 | | _ -> () 668 | end); 669 | in 670 | List.iter !bind_edges ~f:(fun (from, to_) -> 671 | if Hash_set.mem seen to_.id 672 | then fprintf out " %s -> %s [style=dashed]\n" (node_name from) (node_name to_)); 673 | fprintf out "}\n%!") 674 | ;; 675 | end 676 | -------------------------------------------------------------------------------- /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 | 16 | open! Core_kernel 17 | open! Import 18 | 19 | (** For performance reasons, we do not use an OCaml existential type for [Node.Packed.t]: 20 | 21 | {[ 22 | type t = T : _ Node.t -> t 23 | ]} 24 | 25 | The extra indirection when following pointers to packed nodes would be too slow. 26 | 27 | Consequently, there is a possible bug in which we mix the ['a] from two packed nodes 28 | with different types. We reduce the chance of this bug by minimizing the scopes in 29 | which we deal with packed nodes. *) 30 | module Packed : sig 31 | 32 | type t = Types.Packed_node.t [@@deriving sexp_of] 33 | 34 | include Invariant.S with type t := t 35 | 36 | (** [As_list] allows one to view a node as a list w.r.t. a particular [next] pointer 37 | contained within it. The recompute heap uses this with [next_in_recompute_heap], 38 | and the adjust-heights heap uses this with [next_in_adjust_heights_heap]. *) 39 | module As_list 40 | (M : sig 41 | val next : t -> t Uopt.t 42 | end) : sig 43 | 44 | type t = Types.Packed_node.t Uopt.t [@@deriving sexp_of] 45 | 46 | include Invariant.S with type t := t 47 | 48 | val length : t -> int 49 | 50 | val iter : t -> f:(Types.Packed_node.t -> unit) -> unit 51 | 52 | end 53 | 54 | (** [iter_descendants ts ~f] calls [f] on every node in [ts] and all of their 55 | descendants exactly once per node. *) 56 | val iter_descendants : t list -> f:(t -> unit) -> unit 57 | 58 | val save_dot : string -> t list -> unit 59 | 60 | end 61 | 62 | include module type of struct include Types.Node end 63 | 64 | include Invariant.S1 with type 'a t := 'a t 65 | 66 | val create : Scope.t -> 'a Kind.t -> 'a t 67 | 68 | (** One should only set the kind of a node using [set_kind] -- using [t.kind <-] will 69 | violate invariants. *) 70 | val set_kind : 'a t -> 'a Kind.t -> unit 71 | 72 | val pack : _ t -> Packed.t 73 | 74 | val same : _ t -> _ t -> bool 75 | 76 | (** [iteri_children t ~f] applies [f] to all children of [t]. *) 77 | val iteri_children : _ t -> f:(int -> Packed.t -> unit) -> unit 78 | 79 | (*_ 80 | (** [iteri_parents t ~f] applies [f] to all necessary parents of [t]. *) 81 | val iteri_parents : _ t -> f:(int -> Packed.t -> unit) -> unit 82 | *) 83 | 84 | (** [get_parent t ~index] raises unless [0 <= index < t.num_parents]. *) 85 | val get_parent : _ t -> index:int -> Packed.t 86 | 87 | val add_parent : child:'a t -> parent:'b t -> child_index:int -> unit 88 | val remove_parent : child:'a t -> parent:'b t -> child_index:int -> unit 89 | val swap_children_except_in_kind 90 | : _ t 91 | -> child1 : _ t 92 | -> child_index1 : int 93 | -> child2 : _ t 94 | -> child_index2 : int 95 | -> unit 96 | 97 | val is_const : _ t -> bool 98 | 99 | val is_in_recompute_heap : _ t -> bool 100 | 101 | (** [is_necessary t] iff [t] is a descendant of an observer or [t] is a [Freeze] node. *) 102 | val is_necessary : _ t -> bool 103 | 104 | (** [is_valid t] returns [true] iff the left-hand-side of [t]'s defining bind hasn't 105 | changed since [t] was created. *) 106 | val is_valid : _ t -> bool 107 | 108 | (** [should_be_invalidated t] returns [true] iff [t] has an invalid child that implies 109 | that [t] should be invalid. It doesn't take into account [t.created_in]. *) 110 | val should_be_invalidated : _ t -> bool 111 | 112 | (** [edge_is_stale] returns [true] iff [child] has changed since [parent] was computed, 113 | and implies [is_stale parent]. [edge_is_stale] is constant-time. *) 114 | val edge_is_stale : child:_ t -> parent:_ t -> bool 115 | 116 | (** [is_stale t] is true if [t] has never been computed or if some child changed since [t] 117 | was last computed. [is_stale] doesn't take into account [t.created_in]. *) 118 | val is_stale : _ t -> bool 119 | 120 | (** [needs_to_be_computed] is [is_necessary t && is_stale t] *) 121 | val needs_to_be_computed : _ t -> bool 122 | 123 | (** Getting the value of a node. 124 | 125 | [value_exn t] raises iff [Uopt.is_none t.value_opt]. 126 | [unsafe_value t] is safe iff [Uopt.is_some t.value_opt]. *) 127 | val value_exn : 'a t -> 'a 128 | val unsafe_value : 'a t -> 'a 129 | 130 | val get_cutoff : 'a t -> 'a Cutoff.t 131 | val set_cutoff : 'a t -> 'a Cutoff.t -> unit 132 | 133 | (** [on_update t on_update_handler] adds an on-update handler to [t]. *) 134 | val on_update : 'a t -> 'a On_update_handler.t -> unit 135 | 136 | (** [run_on_update_handlers t node_update ~now] runs [t]'s on-update handlers, except 137 | those created at the stabilization [now]. *) 138 | val run_on_update_handlers 139 | : 'a t -> 'a On_update_handler.Node_update.t -> now:Stabilization_num.t -> unit 140 | 141 | val keep_node_creation_backtrace : bool ref 142 | 143 | val user_info : _ t -> Info.t option 144 | val set_user_info : _ t -> Info.t option -> unit 145 | 146 | (** These functions are meant for debug, as they are not very efficient. *) 147 | val has_child : _ t -> child : _ t -> bool 148 | val has_parent : _ t -> parent : _ t -> bool 149 | -------------------------------------------------------------------------------- /src/node_id.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | include Int 5 | 6 | let invariant t = assert (t >= 1) 7 | 8 | let next = 9 | let r = ref 0 in 10 | fun () -> 11 | incr r; 12 | !r 13 | ;; 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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | type t = private int [@@deriving compare, sexp_of] 10 | 11 | include Hashable with type t := t 12 | include Invariant.S with type t := t 13 | 14 | val next : unit -> t 15 | val to_string : t -> string 16 | -------------------------------------------------------------------------------- /src/observer.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 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 | 8 | let observing t = Internal_observer.observing !t 9 | 10 | let use_is_allowed t = Internal_observer.use_is_allowed !t 11 | 12 | let value_exn t = Internal_observer.value_exn !t 13 | 14 | let on_update_exn t on_update_handler = 15 | Internal_observer.on_update_exn !t on_update_handler 16 | ;; 17 | -------------------------------------------------------------------------------- /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 | 10 | open! Core_kernel 11 | open! Import 12 | 13 | include module type of struct include Types.Observer end 14 | 15 | include Invariant.S1 with type 'a t := 'a t 16 | include Sexp_of. S1 with type 'a t := 'a t 17 | 18 | val observing : 'a t -> 'a Node.t 19 | 20 | val use_is_allowed : _ t -> bool 21 | 22 | val value_exn : 'a t -> 'a 23 | 24 | val on_update_exn : 'a t -> 'a On_update_handler.t -> unit 25 | -------------------------------------------------------------------------------- /src/on_update_handler.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 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 = 31 | { f 32 | ; previous_update_kind = Never_been_updated 33 | ; created_at 34 | } 35 | ;; 36 | 37 | let really_run t (node_update : _ Node_update.t) = 38 | t.previous_update_kind <- 39 | (match node_update with 40 | | Necessary _ -> Necessary 41 | | Changed _ -> Changed 42 | | Invalidated -> Invalidated 43 | | Unnecessary -> Unnecessary); 44 | t.f node_update; 45 | ;; 46 | 47 | let run t (node_update : _ Node_update.t) ~now = 48 | (* We only run the handler if was created in an earlier stabilization cycle. If the 49 | handler was created by another on-update handler during the running of on-update 50 | handlers in the current stabilization, we treat the added handler as if it were added 51 | after this stabilization finished. We will run it at the next stabilization, because 52 | the node with the handler was pushed on [state.handle_after_stabilization]. *) 53 | if Stabilization_num.compare t.created_at now < 0 then begin 54 | match t.previous_update_kind, node_update with 55 | (* Once a node is invalidated, there will never be further information to provide, 56 | since incremental does not allow an invalid node to become valid. *) 57 | | Invalidated, _ 58 | -> () 59 | (* These cases can happen if a node is handled after stabilization due to another 60 | handler. But for the current handler, there is nothing to do because there is no 61 | new information to provide. *) 62 | | Changed , Necessary _ 63 | | Necessary , Necessary _ 64 | | Unnecessary, Unnecessary 65 | -> () 66 | (* If this handler hasn't seen a node that is changing, we treat the update as an 67 | initialization. *) 68 | | ( Never_been_updated | Unnecessary ), Changed (_, a) 69 | -> really_run t (Necessary a) 70 | (* All other updates are run as is. *) 71 | | Never_been_updated, ( Necessary _ | Unnecessary | Invalidated ) 72 | | Unnecessary , ( Necessary _ | Invalidated ) 73 | | Necessary , ( Changed _ | Unnecessary | Invalidated ) 74 | | Changed , ( Changed _ | Unnecessary | Invalidated ) 75 | -> really_run t node_update 76 | end; 77 | ;; 78 | -------------------------------------------------------------------------------- /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_kernel 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 | 23 | val run : 'a t -> 'a Node_update.t -> now:Stabilization_num.t -> unit 24 | -------------------------------------------------------------------------------- /src/raised_exn.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | type t = 5 | { exn : exn 6 | ; backtrace : Backtrace.t 7 | } 8 | [@@deriving sexp_of] 9 | 10 | let create exn = 11 | { exn 12 | ; backtrace = Backtrace.Exn.most_recent () 13 | } 14 | ;; 15 | 16 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | type t [@@deriving sexp_of] 11 | 12 | (** [create exn] makes a [t] using [exn] and [Backtrace.Exn.most_recent]. *) 13 | val create : exn -> t 14 | -------------------------------------------------------------------------------- /src/recompute_heap.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | 4 | module As_recompute_list = 5 | Node.Packed.As_list (struct 6 | let next (node : _ Node.t) = node.next_in_recompute_heap 7 | end) 8 | 9 | module Nodes_by_height = struct 10 | type t = As_recompute_list.t Array.t [@@deriving sexp_of] 11 | 12 | (* We display the smallest prefix of [nodes_by_height] that includes all nodes. *) 13 | let sexp_of_t t = 14 | let max_nonempty_index = ref (-1) in 15 | Array.iteri t ~f:(fun i l -> if Uopt.is_some l then max_nonempty_index := i); 16 | Array.sub t ~pos:0 ~len:(!max_nonempty_index + 1) |> [%sexp_of: t] 17 | ;; 18 | end 19 | 20 | type t = 21 | { mutable length : int 22 | ; mutable height_lower_bound : int 23 | ; mutable nodes_by_height : Nodes_by_height.t 24 | } 25 | [@@deriving fields, sexp_of] 26 | 27 | let max_height_allowed t = Array.length t.nodes_by_height - 1 28 | 29 | let is_empty t = t.length = 0 30 | 31 | let invariant t = 32 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> 33 | let check f = Invariant.check_field t f in 34 | Fields.iter 35 | ~length:(check (fun length -> 36 | let actual_length = ref 0 in 37 | Array.iter t.nodes_by_height ~f:(fun node -> 38 | actual_length := !actual_length + As_recompute_list.length node); 39 | [%test_eq: int] length !actual_length)) 40 | ~height_lower_bound:(check (fun height_lower_bound -> 41 | assert (height_lower_bound >= 0); 42 | assert (height_lower_bound <= Array.length t.nodes_by_height); 43 | for height = 0 to height_lower_bound - 1 do 44 | assert (Uopt.is_none t.nodes_by_height.( height )); 45 | done)) 46 | ~nodes_by_height:(check (fun nodes_by_height -> 47 | Array.iteri nodes_by_height ~f:(fun height node -> 48 | As_recompute_list.iter node ~f:(fun node -> 49 | assert (node.height_in_recompute_heap = height); 50 | assert (Node.needs_to_be_computed node)))))) 51 | ;; 52 | 53 | let create_nodes_by_height ~max_height_allowed = 54 | Array.create ~len:(max_height_allowed + 1) Uopt.none 55 | ;; 56 | 57 | let set_max_height_allowed t max_height_allowed = 58 | if verbose 59 | then Debug.ams [%here] "set_max_height_allowed" (max_height_allowed, t) 60 | [%sexp_of: int * t]; 61 | if debug then 62 | for i = max_height_allowed + 1 to Array.length t.nodes_by_height - 1 do 63 | assert (Uopt.is_none t.nodes_by_height.( i )); 64 | done; 65 | let src = t.nodes_by_height in 66 | let dst = create_nodes_by_height ~max_height_allowed in 67 | Array.blit ~src ~src_pos:0 ~dst ~dst_pos:0 68 | ~len:(min (Array.length src) (Array.length dst)); 69 | t.nodes_by_height <- dst; 70 | t.height_lower_bound <- min t.height_lower_bound (Array.length dst); 71 | ;; 72 | 73 | let create ~max_height_allowed = 74 | { length = 0 75 | ; height_lower_bound = max_height_allowed + 1 76 | ; nodes_by_height = create_nodes_by_height ~max_height_allowed 77 | } 78 | ;; 79 | 80 | let link (type a) t (node : a Node.t) = 81 | let height = node.height in 82 | if debug then assert (height <= max_height_allowed t); 83 | node.height_in_recompute_heap <- height; 84 | let next = Array.get t.nodes_by_height height in 85 | node.next_in_recompute_heap <- next; 86 | if Uopt.is_some next 87 | then (Uopt.unsafe_value next).prev_in_recompute_heap <- Uopt.some (Node.pack node); 88 | Array.unsafe_set t.nodes_by_height height (Uopt.some (Node.pack node)); 89 | ;; 90 | 91 | let unlink (type a) t (node : a Node.t) = 92 | let prev = node.prev_in_recompute_heap in 93 | let next = node.next_in_recompute_heap in 94 | if phys_same 95 | (Uopt.some node) 96 | (Array.get t.nodes_by_height node.height_in_recompute_heap) 97 | then Array.unsafe_set t.nodes_by_height node.height_in_recompute_heap next; 98 | if Uopt.is_some next then (Uopt.unsafe_value next).prev_in_recompute_heap <- prev; 99 | if Uopt.is_some prev then (Uopt.unsafe_value prev).next_in_recompute_heap <- next; 100 | node.prev_in_recompute_heap <- Uopt.none; 101 | (* We don't set [node.next_in_recompute_heap] here, but rather after calling [unlink]. *) 102 | ;; 103 | 104 | let add (type a) t (node : a Node.t) = 105 | if verbose 106 | then Debug.ams [%here] "Recompute_heap.add" node [%sexp_of: _ Node.t]; 107 | if debug && (Node.is_in_recompute_heap node || not (Node.needs_to_be_computed node)) 108 | then failwiths "incorrect attempt to add node to recompute heap" node 109 | [%sexp_of: _ Node.t]; 110 | if debug then assert (node.height <= max_height_allowed t); 111 | let height = node.height in 112 | if height < t.height_lower_bound then t.height_lower_bound <- height; 113 | link t node; 114 | t.length <- t.length + 1; 115 | ;; 116 | 117 | let remove (type a) t (node : a Node.t) = 118 | if verbose 119 | then Debug.ams [%here] "Recompute_heap.remove" (node, t) [%sexp_of: _ Node.t * t]; 120 | if debug && (not (Node.is_in_recompute_heap node) || Node.needs_to_be_computed node) 121 | then failwiths "incorrect [remove] of node from recompute heap" node 122 | [%sexp_of: _ Node.t]; 123 | unlink t node; 124 | node.next_in_recompute_heap <- Uopt.none; 125 | node.height_in_recompute_heap <- -1; 126 | t.length <- t.length - 1; 127 | ;; 128 | 129 | let increase_height (type a) t (node : a Node.t) = 130 | if verbose 131 | then Debug.ams [%here] "Recompute_heap.increase_height" node [%sexp_of: _ Node.t]; 132 | if debug then begin 133 | assert (node.height > node.height_in_recompute_heap); 134 | assert (node.height <= max_height_allowed t); 135 | assert (Node.is_in_recompute_heap node); 136 | end; 137 | unlink t node; 138 | link t node; 139 | ;; 140 | 141 | let min_height t = 142 | if t.length = 0 143 | then t.height_lower_bound <- Array.length t.nodes_by_height 144 | else begin 145 | let nodes_by_height = t.nodes_by_height in 146 | while Uopt.is_none (Array.get nodes_by_height t.height_lower_bound) do 147 | t.height_lower_bound <- t.height_lower_bound + 1; 148 | done; 149 | end; 150 | t.height_lower_bound 151 | ;; 152 | 153 | let remove_min t = 154 | if debug then assert (not (is_empty t)); 155 | let nodes_by_height = t.nodes_by_height in 156 | let node = ref (Array.get nodes_by_height t.height_lower_bound) in 157 | while Uopt.is_none !node do 158 | t.height_lower_bound <- t.height_lower_bound + 1; 159 | if debug && t.height_lower_bound >= Array.length t.nodes_by_height 160 | then failwiths "Recompute_heap.remove_min unexpectedly reached end of heap" 161 | t [%sexp_of: t]; 162 | node := Array.get nodes_by_height t.height_lower_bound; 163 | done; 164 | let node = Uopt.unsafe_value !node in 165 | node.height_in_recompute_heap <- -1; 166 | t.length <- t.length - 1; 167 | let next = node.next_in_recompute_heap in 168 | Array.set t.nodes_by_height t.height_lower_bound next; 169 | if Uopt.is_some next 170 | then (Uopt.unsafe_value next).prev_in_recompute_heap <- Uopt.none; 171 | if debug then assert (Uopt.is_none node.prev_in_recompute_heap); 172 | node.next_in_recompute_heap <- Uopt.none; 173 | node 174 | ;; 175 | -------------------------------------------------------------------------------- /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 4 | is used during stabilization to visit the nodes that need to be computed in 5 | topological order, using the recompute heap to visit them in increasing order of 6 | height. 7 | *) 8 | 9 | open! Core_kernel 10 | open! Import 11 | 12 | type t [@@deriving sexp_of] 13 | 14 | include Invariant.S with type t := t 15 | 16 | val create : max_height_allowed:int -> t 17 | 18 | val length : t -> int 19 | 20 | (** [max_height_allowed] is the maximum [node.height] allowed for [node] in [t]. 21 | 22 | It is an error to call [set_max_height_allowed t m] if there is a [node] in [t] with 23 | [node.height > m]. *) 24 | val max_height_allowed : t -> int 25 | val set_max_height_allowed : t -> int -> unit 26 | 27 | (** [min_height t] returns the smallest height of any element in [t], or 28 | [max_height_allowed + 1] if [length t = 0]. *) 29 | val min_height : t -> int 30 | 31 | (** [add t node] should only be called iff: 32 | 33 | {[ 34 | not (Node.is_in_recompute_heap node) 35 | && Node.needs_to_be_computed node 36 | && node.height <= max_height_allowed t 37 | ]} 38 | *) 39 | val add : t -> _ Node.t -> unit 40 | 41 | (** [remove t node] should only be called iff: 42 | 43 | {[ 44 | Node.is_in_recompute_heap node 45 | && not (Node.needs_to_be_computed node) 46 | ]} 47 | *) 48 | val remove : t -> _ Node.t -> unit 49 | 50 | (** [remove_min t] removes and returns a node in [t] with minimum height. [remove_min] 51 | should only be called if [length t > 0]. *) 52 | val remove_min : t -> Node.Packed.t 53 | 54 | (** [increase_height t node] should only be called when: 55 | 56 | - [node.height > node.height_in_recompute_heap] 57 | - [node.height <= max_height_allowed t] 58 | - [Node.is_in_recompute_heap node] 59 | 60 | It changes [node.height_in_recompute_heap] to equal [node.height] and adjusts [node]'s 61 | position in [t]. *) 62 | val increase_height : t -> _ Node.t -> unit 63 | 64 | -------------------------------------------------------------------------------- /src/reduce_balanced.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 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 state node 19 | (Expert1.Dependency.create children.(i) 20 | ~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/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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | val create 10 | : State.t 11 | -> 'a Node.t array 12 | -> f:('a -> 'b) 13 | -> reduce:('b -> 'b -> 'b) 14 | -> 'b Node.t option 15 | -------------------------------------------------------------------------------- /src/scope.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | module Node = Types.Node 5 | 6 | include Types.Scope 7 | 8 | let top = Top 9 | 10 | let is_top = function Top -> true | Bind _ -> false 11 | 12 | let invariant = function 13 | | Top -> () 14 | | Bind bind -> Bind.invariant ignore ignore bind 15 | ;; 16 | 17 | (* Unlike for nodes, there is no invariant [is_necessary t <=> height > -1] (doesn't work 18 | because of [Top]). This is fine since the height of a scope is only used to constrain 19 | other heights, not to schedule it. *) 20 | let height = function 21 | | Top -> -1 22 | | Bind bind -> bind.lhs_change.height 23 | ;; 24 | 25 | let is_valid = function 26 | | Top -> true 27 | | Bind bind -> Bind.is_valid bind 28 | ;; 29 | 30 | let is_necessary = function 31 | | Top -> true 32 | | Bind bind -> Node.is_necessary bind.main 33 | ;; 34 | 35 | let add_node t (node : _ Node.t) = 36 | assert (phys_equal node.created_in t); 37 | if verbose then Debug.ams [%here] "Scope.add_node" (node, t) [%sexp_of: _ Node.t * t]; 38 | match t with 39 | | Top -> () 40 | | Bind bind -> 41 | node.next_node_in_same_scope <- bind.all_nodes_created_on_rhs; 42 | bind.all_nodes_created_on_rhs <- Uopt.some (Node.pack node); 43 | ;; 44 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Scope end 11 | 12 | include Invariant.S with type t := t 13 | 14 | val top : t 15 | 16 | val is_top : t -> bool 17 | 18 | val height : t -> int 19 | 20 | val is_valid : t -> bool 21 | 22 | val is_necessary : t -> bool 23 | 24 | val add_node : t -> _ Types.Node.t -> unit 25 | -------------------------------------------------------------------------------- /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 | 13 | 14 | -------------------------------------------------------------------------------- /src/should_not_use.ml: -------------------------------------------------------------------------------- 1 | open! Core_kernel 2 | open! Import 3 | 4 | type t 5 | 6 | let sexp_of_t = [%sexp_of: _] 7 | -------------------------------------------------------------------------------- /src/should_not_use.mli: -------------------------------------------------------------------------------- 1 | (** A module internal to Incremental. Users should see {!Incremental_intf}. 2 | 3 | In several places, we use [Should_not_use.t] to implement a "lightweight" existential. 4 | I.e. for some type ['a t], we "pack" it by using [Obj.magic] to cast to 5 | [Should_not_use.t t]. This is OK so long as we we never mix the [Should_not_use.t] 6 | parts from two different types that have been so packed. 7 | 8 | We do this for performance reasons, to avoid the boxing and indirection that comes 9 | from OCaml's implementation of packing. It can also make pointer-manipulation code 10 | more transparent. 11 | *) 12 | 13 | type t [@@deriving sexp_of] 14 | -------------------------------------------------------------------------------- /src/snapshot.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type 'a t = 'a Types.Snapshot.t = 8 | { main : 'a Node.t 9 | ; at : Time_ns.t 10 | ; before : 'a 11 | ; value_at : 'a Node.t 12 | } 13 | [@@deriving fields, sexp_of] 14 | 15 | let invariant invariant_a t = 16 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 17 | let check f = Invariant.check_field t f in 18 | Fields.iter 19 | ~main:(check (fun (main : _ Node.t) -> 20 | assert (Scope.is_top main.created_in); 21 | match main.kind with 22 | | Invalid -> () (* happens when snapshotting an invalid node *) 23 | | Const _ -> () (* happens after the snapshot *) 24 | | Snapshot t' -> assert (phys_equal t t') 25 | | _ -> assert false)) 26 | ~at:ignore 27 | ~before:(check invariant_a) 28 | ~value_at:ignore) 29 | ;; 30 | -------------------------------------------------------------------------------- /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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | include module type of struct include Types.Snapshot end 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | include Sexp_of. S1 with type 'a t := 'a t 13 | -------------------------------------------------------------------------------- /src/stabilization_num.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | include Int 5 | 6 | let invariant t = assert (t >= -1) 7 | 8 | let none = -1 9 | 10 | let is_none t = t = none 11 | 12 | let is_some t = t >= 0 13 | 14 | let add1 t = t + 1 15 | -------------------------------------------------------------------------------- /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, 6 | i.e. if one of its children changed at a stabilization since the node was 7 | recomputed. *) 8 | 9 | open! Core_kernel 10 | open! Import 11 | 12 | type t = private int [@@deriving compare, sexp_of] 13 | 14 | include Equal. S with type t := t 15 | include Invariant.S with type t := t 16 | 17 | (** [none <= t] for all [t]. *) 18 | val none : t 19 | 20 | val zero : t 21 | 22 | val is_none : t -> bool 23 | val is_some : t -> bool 24 | 25 | val add1 : t -> t 26 | 27 | val to_int : t -> int 28 | -------------------------------------------------------------------------------- /src/step_function.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type 'a t = 'a Types.Step_function.t = 8 | { main : 'a Node.t 9 | ; mutable value : 'a 10 | ; mutable upcoming_steps : (Time_ns.t * 'a) list 11 | ; mutable alarm : Alarm.t 12 | } 13 | [@@deriving fields, sexp_of] 14 | 15 | let invariant invariant_a t = 16 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 17 | let check f = Invariant.check_field t f in 18 | Fields.iter 19 | ~main:(check (fun (main : _ Node.t) -> 20 | match main.kind with 21 | | Invalid -> () 22 | | Const _ -> () (* happens when [upcoming_steps] becomes empty. *) 23 | | Step_function t' -> assert (phys_equal t t') 24 | | _ -> assert false)) 25 | ~value:(check invariant_a) 26 | ~upcoming_steps:(check (fun upcoming_steps -> 27 | assert (List.is_sorted upcoming_steps ~compare:(fun (time1, _) (time2, _) -> 28 | Time_ns.compare time1 time2)); 29 | List.iter upcoming_steps ~f:(fun (_, a) -> invariant_a a))) 30 | ~alarm:(check Alarm.invariant)) 31 | ;; 32 | 33 | let advance t ~time_passed = 34 | let value = ref t.value in 35 | let upcoming_steps = ref t.upcoming_steps in 36 | let continue = ref true in 37 | while !continue do 38 | match !upcoming_steps with 39 | | [] -> continue := false 40 | | (step_at, a) :: rest -> 41 | if time_passed step_at 42 | then (value := a; upcoming_steps := rest) 43 | else continue := false 44 | done; 45 | t.value <- !value; 46 | t.upcoming_steps <- !upcoming_steps; 47 | ;; 48 | -------------------------------------------------------------------------------- /src/step_function.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 [Time_ns.t] 4 | to ['a] with a finite number of steps. The steps are in nondecreasing time order. 5 | *) 6 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Step_function 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 | val advance : _ t -> time_passed:(Time_ns.t -> bool) -> unit 16 | -------------------------------------------------------------------------------- /src/types.ml: -------------------------------------------------------------------------------- 1 | (* This module has a giant [module rec] defining all the mutually recursive types used 2 | in the implementation. The definition of each type is then repeated in its file; 3 | comments belong there, not here. 4 | 5 | We put just enough sexp converters here to display node ids. The detailed sexp 6 | converters are generated via [with sexp] in the individual files. Defining the sexp 7 | converters outside of the [module rec] makes it impossible to accidentally introduce a 8 | sexp converter that would try to produce an infinite sexp. 9 | *) 10 | 11 | open Core_kernel 12 | open Import 13 | 14 | module rec Alarm : sig 15 | type t = Alarm_value.t Timing_wheel_ns.Alarm.t 16 | end = Alarm 17 | 18 | and Alarm_value : sig 19 | module Action : sig 20 | type t = 21 | | At of At.t 22 | | At_intervals of At_intervals.t 23 | | Snapshot : _ Snapshot.t -> t 24 | | Step_function : _ Step_function.t -> t 25 | end 26 | type t = 27 | { action : Action.t 28 | ; mutable next_fired : t Uopt.t 29 | } 30 | end = Alarm_value 31 | 32 | and Array_fold : sig 33 | type ('a, 'acc) t = 34 | { init : 'acc 35 | ; f : 'acc -> 'a -> 'acc 36 | ; children : 'a Node.t array 37 | } 38 | end = Array_fold 39 | 40 | and At : sig 41 | type t = 42 | { main : Before_or_after.t Node.t 43 | ; at : Time_ns.t 44 | ; mutable alarm : Alarm.t 45 | } 46 | end = At 47 | 48 | and At_intervals : sig 49 | type t = 50 | { main : unit Node.t 51 | ; base : Time_ns.t 52 | ; interval : Time_ns.Span.t 53 | ; mutable alarm : Alarm.t 54 | } 55 | end = At_intervals 56 | 57 | and Bind : sig 58 | type ('a, 'b) t = 59 | { main : 'b Node.t 60 | ; mutable f : 'a -> 'b Node.t 61 | ; lhs : 'a Node.t 62 | ; lhs_change : unit Node.t 63 | ; mutable rhs : 'b Node.t Uopt.t 64 | ; mutable rhs_scope : Scope.t 65 | ; mutable all_nodes_created_on_rhs : Packed_node.t Uopt.t 66 | } 67 | end = Bind 68 | 69 | and Expert : sig 70 | type 'a edge = 71 | { child : 'a Node.t 72 | ; on_change : 'a -> unit 73 | ; mutable index : int Uopt.t 74 | } 75 | 76 | type packed_edge = E : 'a edge -> packed_edge 77 | 78 | type 'a t = 79 | { f : unit -> 'a 80 | ; on_observability_change : is_now_observable:bool -> unit 81 | ; mutable children : packed_edge Uopt.t Array.t 82 | ; mutable num_children : int 83 | ; mutable force_stale : bool 84 | ; mutable num_invalid_children : int 85 | ; mutable will_fire_all_callbacks : bool 86 | } 87 | end = Expert 88 | 89 | and Freeze : sig 90 | type 'a t = 91 | { main : 'a Node.t 92 | ; child : 'a Node.t 93 | ; only_freeze_when : ('a -> bool) 94 | } 95 | end = Freeze 96 | 97 | and If_then_else : sig 98 | type 'a t = 99 | { main : 'a Node.t 100 | ; test : bool Node.t 101 | ; test_change : unit Node.t 102 | ; mutable current_branch : 'a Node.t Uopt.t 103 | ; then_ : 'a Node.t 104 | ; else_ : 'a Node.t 105 | } 106 | end = If_then_else 107 | 108 | and Internal_observer : sig 109 | module State : sig 110 | type t = Created | In_use | Disallowed | Unlinked 111 | end 112 | type 'a t = 113 | { mutable state : State.t 114 | ; observing : 'a Node.t 115 | ; mutable on_update_handlers : 'a On_update_handler.t list 116 | ; mutable prev_in_all : Packed_internal_observer.t Uopt.t 117 | ; mutable next_in_all : Packed_internal_observer.t Uopt.t 118 | ; mutable prev_in_observing : 'a t Uopt.t 119 | ; mutable next_in_observing : 'a t Uopt.t 120 | } 121 | end = Internal_observer 122 | 123 | and Join : sig 124 | type 'a t = 125 | { main : 'a Node.t 126 | ; lhs : 'a Node.t Node.t 127 | ; lhs_change : unit Node.t 128 | ; mutable rhs : 'a Node.t Uopt.t 129 | } 130 | end = Join 131 | 132 | and Kind : sig 133 | type 'a t = 134 | | Array_fold : (_, 'a) Array_fold.t -> 'a t 135 | | At : At.t -> Before_or_after.t t 136 | | At_intervals : At_intervals.t -> unit t 137 | | Bind_lhs_change : (_, _) Bind.t -> unit t 138 | | Bind_main : (_, 'a) Bind.t -> 'a t 139 | | Const of 'a 140 | | Expert of 'a Expert.t 141 | | Freeze of 'a Freeze.t 142 | | If_test_change : _ If_then_else.t -> unit t 143 | | If_then_else of 'a If_then_else.t 144 | | Invalid 145 | | Join_lhs_change : _ Join.t -> unit t 146 | | Join_main of 'a Join.t 147 | | Map : ('a1 -> 'a) * 'a1 Node.t -> 'a t 148 | | Snapshot of 'a Snapshot.t 149 | | Step_function of 'a Step_function.t 150 | | Uninitialized 151 | | Unordered_array_fold : (_, 'a) Unordered_array_fold.t -> 'a t 152 | | Var of 'a Var.t 153 | | Map2 154 | : ('a1 -> 'a2 -> 'a) 155 | * 'a1 Node.t * 'a2 Node.t 156 | -> 'a t 157 | | Map3 158 | : ('a1 -> 'a2 -> 'a3 -> 'a) 159 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t 160 | -> 'a t 161 | | Map4 162 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a) 163 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t 164 | -> 'a t 165 | | Map5 166 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a) 167 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t 168 | -> 'a t 169 | | Map6 170 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a) 171 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 172 | -> 'a t 173 | | Map7 174 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a) 175 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 176 | * 'a7 Node.t 177 | -> 'a t 178 | | Map8 179 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a) 180 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 181 | * 'a7 Node.t * 'a8 Node.t 182 | -> 'a t 183 | | Map9 184 | : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 -> 'a) 185 | * 'a1 Node.t * 'a2 Node.t * 'a3 Node.t * 'a4 Node.t * 'a5 Node.t * 'a6 Node.t 186 | * 'a7 Node.t * 'a8 Node.t * 'a9 Node.t 187 | -> 'a t 188 | end = Kind 189 | 190 | and Node : sig 191 | type 'a t = 192 | { id : Node_id.t 193 | ; mutable recomputed_at : Stabilization_num.t 194 | ; mutable value_opt : 'a Uopt.t 195 | ; mutable kind : 'a Kind.t 196 | ; mutable cutoff : 'a Cutoff.t 197 | ; mutable changed_at : Stabilization_num.t 198 | ; mutable num_on_update_handlers : int 199 | ; mutable num_parents : int 200 | ; mutable parent1_and_beyond : Packed_node.t Uopt.t array 201 | ; mutable parent0 : Packed_node.t Uopt.t 202 | ; mutable created_in : Scope.t 203 | ; mutable next_node_in_same_scope : Packed_node.t Uopt.t 204 | ; mutable height : int 205 | ; mutable height_in_recompute_heap : int 206 | ; mutable prev_in_recompute_heap : Packed_node.t Uopt.t 207 | ; mutable next_in_recompute_heap : Packed_node.t Uopt.t 208 | ; mutable height_in_adjust_heights_heap : int 209 | ; mutable next_in_adjust_heights_heap : Packed_node.t Uopt.t 210 | ; mutable old_value_opt : 'a Uopt.t 211 | ; mutable observers : 'a Internal_observer.t Uopt.t 212 | ; mutable is_in_handle_after_stabilization : bool 213 | ; mutable on_update_handlers : 'a On_update_handler.t list 214 | ; mutable my_parent_index_in_child_at_index : int array 215 | ; mutable my_child_index_in_parent_at_index : int array 216 | ; mutable force_necessary : bool 217 | ; mutable user_info : Info.t option 218 | ; creation_backtrace : Backtrace.t option 219 | } 220 | [@@deriving sexp_of] 221 | 222 | val pack : _ t -> Packed_node.t 223 | val is_valid : _ t -> bool 224 | val is_necessary : _ t -> bool 225 | 226 | end = struct 227 | include Node 228 | 229 | let sexp_of_t _ t = concat [ "n"; Node_id.to_string t.id ] |> [%sexp_of: string] 230 | 231 | let pack (type a) t = (Obj.magic (t : a t) : Should_not_use.t t) 232 | 233 | let is_valid t = 234 | match t.kind with 235 | | Invalid -> false 236 | | _ -> true 237 | ;; 238 | 239 | (* [is_necessary] is defined here because we need it before node.ml is available. It is 240 | used during graph manipulation, and so is written with some care to be fast. *) 241 | let is_necessary t = 242 | t.num_parents > 0 243 | || Uopt.is_some t.observers 244 | || (match t.kind with Freeze _ -> true | _ -> false) 245 | || t.force_necessary 246 | ;; 247 | end 248 | 249 | and Observer : sig 250 | type 'a t = 'a Internal_observer.t ref 251 | end = Observer 252 | 253 | and Packed_internal_observer : sig 254 | type t = T : _ Internal_observer.t -> t 255 | end = Packed_internal_observer 256 | 257 | and Packed_node : sig 258 | type t = Should_not_use.t Node.t [@@deriving sexp_of] 259 | end = struct 260 | include Packed_node 261 | let sexp_of_t t = t |> [%sexp_of: _ Node.t] 262 | end 263 | 264 | and Scope : sig 265 | type t = Top | Bind : (_, _) Bind.t -> t [@@deriving sexp_of] 266 | end = struct 267 | type t = Top | Bind : (_, _) Bind.t -> t 268 | 269 | let sexp_of_t = function 270 | | Top -> "Top" |> [%sexp_of: string] 271 | | Bind bind -> bind.main |> [%sexp_of: _ Node.t] 272 | ;; 273 | end 274 | 275 | and Snapshot : sig 276 | type 'a t = 277 | { main : 'a Node.t 278 | ; at : Time_ns.t 279 | ; before : 'a 280 | ; value_at : 'a Node.t 281 | } 282 | end = Snapshot 283 | 284 | and Step_function : sig 285 | type 'a t = 286 | { main : 'a Node.t 287 | ; mutable value : 'a 288 | ; mutable upcoming_steps : (Time_ns.t * 'a) list 289 | ; mutable alarm : Alarm.t 290 | } 291 | end = Step_function 292 | 293 | and Unordered_array_fold : sig 294 | type ('a, 'acc) t = 295 | { main : 'acc Node.t 296 | ; init : 'acc 297 | ; f : ('acc -> 'a -> 'acc) 298 | ; f_inverse : ('acc -> 'a -> 'acc) 299 | ; full_compute_every_n_changes : int 300 | ; children : 'a Node.t array 301 | ; mutable fold_value : 'acc Uopt.t 302 | ; mutable num_changes_since_last_full_compute : int 303 | } 304 | end = Unordered_array_fold 305 | 306 | and Var : sig 307 | type 'a t = 308 | { mutable value : 'a 309 | ; mutable value_set_during_stabilization : 'a Uopt.t 310 | ; mutable set_at : Stabilization_num.t 311 | ; watch : 'a Node.t 312 | } 313 | end = Var 314 | -------------------------------------------------------------------------------- /src/unordered_array_fold.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Import 3 | open Types.Kind 4 | 5 | module Node = Types.Node 6 | 7 | type ('a, 'acc) t = ('a, 'acc) Types.Unordered_array_fold.t = 8 | { main : 'acc Node.t 9 | ; init : 'acc 10 | ; f : ('acc -> 'a -> 'acc) 11 | ; f_inverse : ('acc -> 'a -> 'acc) 12 | ; full_compute_every_n_changes : int 13 | ; children : 'a Node.t array 14 | ; mutable fold_value : 'acc Uopt.t 15 | ; mutable num_changes_since_last_full_compute : int 16 | } 17 | [@@deriving fields, sexp_of] 18 | 19 | let same (t1 : (_, _) t) (t2 : (_, _) t) = phys_same t1 t2 20 | 21 | let invariant invariant_a invariant_acc t = 22 | Invariant.invariant [%here] t [%sexp_of: (_, _) t] (fun () -> 23 | let check f = Invariant.check_field t f in 24 | Fields.iter 25 | ~main:(check (fun (main : _ Node.t) -> 26 | match main.kind with 27 | | Invalid -> () 28 | | Unordered_array_fold t' -> assert (same t t') 29 | | _ -> assert false)) 30 | ~init:(check invariant_acc) 31 | ~f:ignore 32 | ~f_inverse:ignore 33 | ~children:(check (fun children -> 34 | Array.iter children ~f:(fun (child : _ Node.t) -> 35 | Uopt.invariant invariant_a child.value_opt; 36 | if t.num_changes_since_last_full_compute < t.full_compute_every_n_changes 37 | then assert (Uopt.is_some child.value_opt)))) 38 | ~fold_value:(check (fun fold_value -> 39 | Uopt.invariant invariant_acc fold_value; 40 | [%test_result: bool] (Uopt.is_some fold_value) 41 | ~expect:(t.num_changes_since_last_full_compute 42 | < t.full_compute_every_n_changes))) 43 | ~num_changes_since_last_full_compute: 44 | (check (fun num_changes_since_last_full_compute -> 45 | assert (num_changes_since_last_full_compute >= 0); 46 | assert (num_changes_since_last_full_compute <= t.full_compute_every_n_changes))) 47 | ~full_compute_every_n_changes:(check (fun full_compute_every_n_changes -> 48 | assert (full_compute_every_n_changes > 0)))) 49 | ;; 50 | 51 | let create ~init ~f ~f_inverse ~full_compute_every_n_changes ~children ~main = 52 | { init 53 | ; f 54 | ; f_inverse 55 | ; full_compute_every_n_changes 56 | ; children 57 | ; main 58 | ; fold_value = Uopt.none 59 | (* We make [num_changes_since_last_full_compute = full_compute_every_n_changes] 60 | so that there will be a full computation the next time the node is computed. *) 61 | ; num_changes_since_last_full_compute = full_compute_every_n_changes 62 | } 63 | ;; 64 | 65 | let full_compute { init; f; children; _ } = 66 | let result = ref init in 67 | for i = 0 to Array.length children - 1 do 68 | result := f !result (Uopt.value_exn (Array.unsafe_get children i).value_opt); 69 | done; 70 | !result 71 | ;; 72 | 73 | let compute t = 74 | if verbose 75 | then Debug.ams [%here] "Unordered_array_fold.compute" t [%sexp_of: (_, _) t]; 76 | if t.num_changes_since_last_full_compute = t.full_compute_every_n_changes then begin 77 | t.num_changes_since_last_full_compute <- 0; 78 | t.fold_value <- Uopt.some (full_compute t); 79 | end; 80 | Uopt.value_exn t.fold_value 81 | ;; 82 | 83 | let force_full_compute t = 84 | t.fold_value <- Uopt.none; 85 | t.num_changes_since_last_full_compute <- t.full_compute_every_n_changes; 86 | ;; 87 | 88 | let child_changed t ~old_value_opt ~new_value = 89 | if t.num_changes_since_last_full_compute < t.full_compute_every_n_changes - 1 90 | then begin 91 | t.num_changes_since_last_full_compute <- t.num_changes_since_last_full_compute + 1; 92 | t.fold_value <- Uopt.some (t.f (t.f_inverse 93 | (Uopt.value_exn t.fold_value) 94 | (Uopt.value_exn old_value_opt)) 95 | new_value); 96 | end else if t.num_changes_since_last_full_compute < t.full_compute_every_n_changes 97 | then force_full_compute t; 98 | ;; 99 | -------------------------------------------------------------------------------- /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 | 7 | open! Core_kernel 8 | open! Import 9 | 10 | include module type of struct include Types.Unordered_array_fold end 11 | 12 | include Invariant.S2 with type ('a, 'acc) t := ('a, 'acc) t 13 | include Sexp_of. S2 with type ('a, 'acc) t := ('a, 'acc) t 14 | 15 | val create 16 | : init:'acc 17 | -> f:('acc -> 'a -> 'acc) 18 | -> f_inverse:('acc -> 'a -> 'acc) 19 | -> full_compute_every_n_changes:int 20 | -> children:'a Types.Node.t array 21 | -> main:'acc Types.Node.t 22 | -> ('a, 'acc) t 23 | 24 | val compute : (_, 'acc) t -> 'acc 25 | 26 | val child_changed : ('a, _) t -> old_value_opt:'a Uopt.t -> new_value:'a -> unit 27 | 28 | val force_full_compute : (_, _) t -> unit 29 | 30 | -------------------------------------------------------------------------------- /src/var.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open! Import 3 | 4 | module Node = Types.Node 5 | 6 | type 'a t = 'a Types.Var.t = 7 | { mutable value : 'a 8 | (* [value_set_during_stabilization] is only set to [Uopt.some] if the user calls 9 | [Var.set] during stabilization, in which case it holds the (last) value set. At the 10 | end of stabilization, all such variables are processed to do [t.value <- 11 | t.value_set_during_stabilization]. *) 12 | ; mutable value_set_during_stabilization : 'a Uopt.t 13 | (* [set_at] the stabilization number in effect the most recent time [t.value] changed. 14 | This is not necessarily the same as the stabilization number in effect the most 15 | recent time [Var.set t] was called, due to the effect of [Var.set] during 16 | stabilization being delayed until after the stabilization. *) 17 | ; mutable set_at : Stabilization_num.t 18 | ; watch : 'a Node.t 19 | } 20 | [@@deriving fields, sexp_of] 21 | 22 | let invariant invariant_a t = 23 | Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> 24 | let check f = Invariant.check_field t f in 25 | Fields.iter 26 | ~value:(check invariant_a) 27 | ~value_set_during_stabilization:(check (Uopt.invariant invariant_a)) 28 | ~set_at:(check Stabilization_num.invariant) 29 | ~watch:(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 | 37 | module Packed = struct 38 | type nonrec t = Should_not_use.t t [@@deriving sexp_of] 39 | end 40 | 41 | let pack (type a) t = (Obj.magic (t : a t) : Should_not_use.t t) 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 | -------------------------------------------------------------------------------- /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 | 6 | open! Core_kernel 7 | open! Import 8 | 9 | include module type of struct include Types.Var end 10 | 11 | include Invariant.S1 with type 'a t := 'a t 12 | include Sexp_of. S1 with type 'a t := 'a t 13 | 14 | module Packed : sig 15 | type nonrec t = Should_not_use.t t [@@deriving sexp_of] 16 | end 17 | 18 | val pack : _ t -> Packed.t 19 | 20 | val latest_value : 'a t -> 'a 21 | -------------------------------------------------------------------------------- /test/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | include Expect_test_helpers 5 | 6 | module Incremental = Incremental_kernel 7 | -------------------------------------------------------------------------------- /test/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name incremental_kernel_test) 3 | (libraries (incremental_kernel 4 | expect_test_helpers)) 5 | (preprocess (pps (ppx_jane ppxlib.runner))))) 6 | 7 | 8 | (jbuild_version 1) 9 | -------------------------------------------------------------------------------- /test/test_balanced_reducer.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Import 4 | open! Incremental_kernel.Private.Balanced_reducer 5 | 6 | type a = int list [@@deriving sexp_of] 7 | 8 | let show_reduce = ref true 9 | 10 | let reduce a1 a2 = 11 | if !show_reduce then print_s [%message "reduce" ~_:(a1 : a) ~_:(a2 : a)]; 12 | a1 @ a2 13 | ;; 14 | 15 | let invariant t = invariant ignore t 16 | 17 | let create_exn ~len : a t = 18 | let t = create_exn () ~len ~reduce ~sexp_of_a in 19 | invariant t; 20 | t 21 | ;; 22 | 23 | let set_exn t i v = 24 | set_exn t i [ v ]; 25 | invariant t; 26 | ;; 27 | 28 | let compute_exn t = 29 | print_s [%message "computed" ~_:(compute_exn t : a)]; 30 | invariant t; 31 | ;; 32 | 33 | let show t = print_s [%message "" ~_:(t : a t)] 34 | 35 | let%expect_test "[create] with invalid length" = 36 | show_raise (fun () -> create_exn ~len:0); 37 | [%expect {| 38 | (raised ("non-positive number of leaves in balanced reducer" (num_leaves 0))) |}]; 39 | ;; 40 | 41 | let%expect_test "[set_exn] with invalid index" = 42 | let t = create_exn ~len:1 in 43 | show_raise (fun () -> set_exn t (-1) 13); 44 | let%bind () = [%expect {| 45 | (raised ("attempt to set negative index in balanced reducer" (index -1))) |}] in 46 | show_raise (fun () -> set_exn t 1 13); 47 | let%bind () = [%expect {| 48 | (raised ( 49 | "attempt to set out of bounds index in balanced reducer" 50 | (index 1) 51 | (length 1))) |}] in 52 | return (); 53 | ;; 54 | 55 | let%expect_test "[sexp_of_t]" = 56 | let t = create_exn ~len:1 in 57 | show t; 58 | let%bind () = [%expect {| 59 | (()) |}] in 60 | set_exn t 0 13; 61 | show t; 62 | let%bind () = [%expect {| 63 | (((13))) |}] in 64 | let t = create_exn ~len:2 in 65 | show t; 66 | let%bind () = [%expect {| 67 | (() 68 | ()) |}] in 69 | set_exn t 0 13; 70 | show t; 71 | let%bind () = [%expect {| 72 | (((13)) ()) |}] in 73 | set_exn t 1 14; 74 | show t; 75 | let%bind () = [%expect {| 76 | (((13)) 77 | ((14))) |}] in 78 | return (); 79 | ;; 80 | 81 | let%expect_test "[compute_exn] with a [None]" = 82 | let t = create_exn ~len:1 in 83 | show_raise (fun () -> compute_exn t); 84 | [%expect {| 85 | (raised ( 86 | "attempt to compute balanced reducer with unset elements" 87 | (balanced_reducer (())))) |}]; 88 | ;; 89 | 90 | let%expect_test "[compute_exn] with a [None]" = 91 | let t = create_exn ~len:2 in 92 | set_exn t 0 13; 93 | show_raise (fun () -> compute_exn t); 94 | [%expect {| 95 | (raised ( 96 | "attempt to compute balanced reducer with unset elements" 97 | (balanced_reducer (((13)) ())))) |}]; 98 | ;; 99 | 100 | let%expect_test "[compute_exn]" = 101 | let t = create_exn ~len:1 in 102 | set_exn t 0 13; 103 | compute_exn t; 104 | let%bind () = [%expect {| 105 | (computed (13)) |}] in 106 | return (); 107 | ;; 108 | 109 | let%expect_test "[compute_exn] caches [reduce]" = 110 | let t = create_exn ~len:2 in 111 | set_exn t 0 13; 112 | set_exn t 1 14; 113 | compute_exn t; 114 | let%bind () = [%expect {| 115 | (reduce 116 | (13) 117 | (14)) 118 | (computed (13 14)) |}] in 119 | compute_exn t; 120 | let%bind () = [%expect {| 121 | (computed (13 14)) |}] in 122 | return (); 123 | ;; 124 | 125 | let%expect_test "[compute_exn] recomputes when input changes" = 126 | let t = create_exn ~len:2 in 127 | set_exn t 0 13; 128 | set_exn t 1 14; 129 | compute_exn t; 130 | let%bind () = [%expect {| 131 | (reduce 132 | (13) 133 | (14)) 134 | (computed (13 14)) |}] in 135 | set_exn t 1 15; 136 | compute_exn t; 137 | let%bind () = [%expect {| 138 | (reduce 139 | (13) 140 | (15)) 141 | (computed (13 15)) |}] in 142 | return (); 143 | ;; 144 | 145 | let%expect_test "[compute_exn] only recomputes what's necessary" = 146 | let t = create_exn ~len:3 in 147 | set_exn t 0 13; 148 | set_exn t 1 14; 149 | set_exn t 2 15; 150 | compute_exn t; 151 | let%bind () = [%expect {| 152 | (reduce 153 | (13) 154 | (14)) 155 | (reduce (13 14) (15)) 156 | (computed (13 14 15)) |}] in 157 | set_exn t 2 16; 158 | compute_exn t; 159 | let%bind () = [%expect {| 160 | (reduce (13 14) (16)) 161 | (computed (13 14 16)) |}] in 162 | return (); 163 | ;; 164 | 165 | let%expect_test "[compute_exn] only recomputes what's necessary; larger example" = 166 | let t = create_exn ~len:10 in 167 | for i = 0 to 9 do set_exn t i (i+13) done; 168 | compute_exn t; 169 | let%bind () = [%expect {| 170 | (reduce 171 | (21) 172 | (22)) 173 | (reduce 174 | (19) 175 | (20)) 176 | (reduce 177 | (19 20) 178 | (21 22)) 179 | (reduce 180 | (17) 181 | (18)) 182 | (reduce 183 | (15) 184 | (16)) 185 | (reduce 186 | (13) 187 | (14)) 188 | (reduce 189 | (13 14) 190 | (15 16)) 191 | (reduce (13 14 15 16) (17 18)) 192 | (reduce (13 14 15 16 17 18) (19 20 21 22)) 193 | (computed (13 14 15 16 17 18 19 20 21 22)) |}] in 194 | set_exn t 9 23; 195 | compute_exn t; 196 | let%bind () = [%expect {| 197 | (reduce 198 | (21) 199 | (23)) 200 | (reduce 201 | (19 20) 202 | (21 23)) 203 | (reduce (13 14 15 16 17 18) (19 20 21 23)) 204 | (computed (13 14 15 16 17 18 19 20 21 23)) |}] in 205 | set_exn t 0 12; 206 | set_exn t 9 24; 207 | compute_exn t; 208 | let%bind () = [%expect {| 209 | (reduce 210 | (21) 211 | (24)) 212 | (reduce 213 | (19 20) 214 | (21 24)) 215 | (reduce 216 | (12) 217 | (14)) 218 | (reduce 219 | (12 14) 220 | (15 16)) 221 | (reduce (12 14 15 16) (17 18)) 222 | (reduce (12 14 15 16 17 18) (19 20 21 24)) 223 | (computed (12 14 15 16 17 18 19 20 21 24)) |}] in 224 | return (); 225 | ;; 226 | 227 | let%expect_test "different lengths" = 228 | Ref.set_temporarily show_reduce false ~f:(fun () -> 229 | for len = 1 to 10 do 230 | let t = create_exn ~len in 231 | for i = 0 to len - 1 do 232 | set_exn t i i; 233 | done; 234 | compute_exn t; 235 | for i = 0 to len - 1 do 236 | set_exn t i i; 237 | done; 238 | for i = 0 to len - 1 do 239 | set_exn t i (len -1 - i); 240 | done; 241 | compute_exn t; 242 | done); 243 | [%expect {| 244 | (computed (0)) 245 | (computed (0)) 246 | (computed (0 1)) 247 | (computed (1 0)) 248 | (computed (0 1 2)) 249 | (computed (2 1 0)) 250 | (computed (0 1 2 3)) 251 | (computed (3 2 1 0)) 252 | (computed (0 1 2 3 4)) 253 | (computed (4 3 2 1 0)) 254 | (computed (0 1 2 3 4 5)) 255 | (computed (5 4 3 2 1 0)) 256 | (computed (0 1 2 3 4 5 6)) 257 | (computed (6 5 4 3 2 1 0)) 258 | (computed (0 1 2 3 4 5 6 7)) 259 | (computed (7 6 5 4 3 2 1 0)) 260 | (computed (0 1 2 3 4 5 6 7 8)) 261 | (computed (8 7 6 5 4 3 2 1 0)) 262 | (computed (0 1 2 3 4 5 6 7 8 9)) 263 | (computed (9 8 7 6 5 4 3 2 1 0)) |}]; 264 | ;; 265 | -------------------------------------------------------------------------------- /test/test_balanced_reducer.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /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 Config = Incremental.Config.Default () in 6 | let config = Config.timing_wheel_config in 7 | let durations = Timing_wheel_ns.Config.durations config in 8 | require [%here] (Time_ns.Span.( >= ) (List.last_exn durations) Time_ns.Span.day); 9 | print_s [%message 10 | "" 11 | ~alarm_precision:(Timing_wheel_ns.Config.alarm_precision config : Time_ns.Span.t) 12 | (durations : Time_ns.Span.t list)]; 13 | [%expect {| 14 | ((alarm_precision 1.048576ms) 15 | (durations (17.179869184s 1d15h5m37.488355328s 52d2h59m59.627370496s))) |}]; 16 | ;; 17 | -------------------------------------------------------------------------------- /test/test_config.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_deprecation.mlt: -------------------------------------------------------------------------------- 1 | module Incr = Incremental_kernel.Incremental.Make () 2 | 3 | [%%expect {| 4 | Line _, characters 14-49: 5 | Error (Warning 3): deprecated: module Incremental_kernel.Incremental 6 | [since 2018-06] Use the [Incremental_kernel] library directly. 7 | |}];; 8 | 9 | module type S = Incremental_kernel.Incremental_intf.S 10 | 11 | [%%expect {| 12 | Line _, characters 16-53: 13 | Error (Warning 3): deprecated: module Incremental_kernel.Incremental_intf 14 | [since 2018-06] Use [Incremental_kernel.S]. 15 | |}];; 16 | -------------------------------------------------------------------------------- /test/test_let_syntax.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Import 4 | 5 | module I = Incremental.Make () 6 | open I 7 | 8 | let%expect_test "simple examples of [let%map] and [let%bind]" = 9 | let () = 10 | let open I.Let_syntax in 11 | let xi = Var.create 13 in 12 | let i1 = 13 | let%map_open a = watch xi 14 | and b = watch xi in 15 | a + b 16 | in 17 | let xb = Var.create true in 18 | let i2 = 19 | let%bind_open b = watch xb in 20 | if b 21 | then return 17 else return 19 22 | in 23 | let o1 = observe i1 in 24 | let o2 = observe i2 in 25 | I.stabilize (); 26 | print_s [%message 27 | "" 28 | (Observer.value o1 : int Or_error.t) 29 | (Observer.value o2 : int Or_error.t)]; 30 | in 31 | [%expect {| 32 | (("Observer.value o1" (Ok 26)) 33 | ("Observer.value o2" (Ok 17))) |}]; 34 | ;; 35 | -------------------------------------------------------------------------------- /test/test_let_syntax.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | --------------------------------------------------------------------------------