diff --git a/CHANGELOG.md b/CHANGELOG.md index dda0db3f45..88c60f35bd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,16 +20,12 @@ #### :bug: Bug fix -- Reanalyze server: invalidate cache and recompute results when config changes in `rescript.json`. https://github.com/rescript-lang/rescript/pull/8262 - #### :memo: Documentation #### :nail_care: Polish #### :house: Internal -- Reanalyze server: redesign incremental fixpoint with delete-then-rederive strategy and predecessor tracking, improving speed on deletions. https://github.com/rescript-lang/rescript/pull/8276 - # 13.0.0-alpha.2 #### :bug: Bug fix diff --git a/analysis/reactive/README.md b/analysis/reactive/README.md index 9f55e57eff..813cae749f 100644 --- a/analysis/reactive/README.md +++ b/analysis/reactive/README.md @@ -8,7 +8,7 @@ This library provides composable reactive collections that automatically propaga ### Key Features -- **Delta-based updates**: Changes propagate as `Set`, `Remove`, or `Batch` deltas +- **Delta-based updates**: Changes propagate as `Batch` deltas - **Glitch-free semantics**: Topological scheduling ensures consistent updates - **Composable combinators**: `flatMap`, `join`, `union`, `fixpoint` - **Incremental fixpoint**: Efficient transitive closure with support for additions and removals @@ -44,7 +44,7 @@ let reachable = fixpoint ~name:"reachable" () (* Emit changes *) -emit (Set ("file.res", file_data)) +emit (set_delta ("file.res", file_data)) emit (Batch [set "a.res" data_a; set "b.res" data_b]) ``` @@ -106,4 +106,3 @@ This library powers the reactive dead code analysis in reanalyze: - `ReactiveMerge`: Merges per-file data into global collections - `ReactiveLiveness`: Computes live declarations via fixpoint - `ReactiveSolver`: Generates dead code issues reactively - diff --git a/analysis/reactive/STABLE_SAFETY.md b/analysis/reactive/STABLE_SAFETY.md new file mode 100644 index 0000000000..fa4a5fb451 --- /dev/null +++ b/analysis/reactive/STABLE_SAFETY.md @@ -0,0 +1,213 @@ +# Stable-Safety Guide + +## What is stable-safety? + +A module is **stable-safe** when it contains zero calls to `Stable.unsafe_of_value`. +This means all values stored in stable containers (`StableMap`, `StableSet`, +`StableWave`) are known to be stable by construction — their `Stable.t` types +flow from the module's inputs, not from unchecked casts. + +`Stable.unsafe_of_value` is the only truly unsafe operation in the system: if a +minor-heap value is stored in a stable container, the GC may relocate it and the +container will hold a dangling pointer. Eliminating it from a module proves that +module cannot cause such corruption. + +## Reading values back: linear vs non-linear + +`Stable.to_linear_value` reads a value from stable storage. The caller must +consume it immediately — don't stash it in a long-lived OCaml structure. This +is safe because the value is used and discarded before the stable container +could overwrite or destroy the slot. + +`Stable.unsafe_to_nonlinear_value` is for cases where the value *will* be +stored in a long-lived structure (hashtable, accumulator list, returned to +caller). This is safe only when the stable container will not destroy or +overwrite the slot while the OCaml reference is alive. Each call site must +be audited individually. Use `grep unsafe_to_nonlinear_value` to find them. + +**When to use which:** +- Comparison, field access, `PosSet.iter`, passing to a pure function → `to_linear_value` +- Storing in a `Hashtbl`, consing onto a ref list, returning `Some v` → `unsafe_to_nonlinear_value` + +## How to audit a module + +1. **Count `unsafe_of_value` calls.** Zero means the module is stable-safe. + +2. **For each call, ask: why is this needed?** Common reasons: + - A callback/function field operates on raw `'v` instead of `'v Stable.t` + - A value was prematurely unwrapped with `to_linear_value` and needs + rewrapping + - An intermediate computation produces a raw value that must be stored + +3. **Classify each call as eliminable or boundary.** + +4. **Audit `unsafe_to_nonlinear_value` calls.** For each, verify the stable + container won't destroy/overwrite the slot during the value's lifetime. + +## How to fix violations + +### Pattern 1: Thread `Stable.t` through instead of unwrap/rewrap + +**Before (violation):** +```ocaml +let v = Stable.to_linear_value (StableMap.find map k) in +(* ... use v ... *) +StableMap.replace other_map k (Stable.unsafe_of_value v) +``` + +**After (safe):** +```ocaml +let v = StableMap.find map k in (* v : 'v Stable.t *) +(* ... pass v as Stable.t ... *) +StableMap.replace other_map k v (* no conversion needed *) +``` + +The key insight: if a value came from a stable container, it already has type +`'v Stable.t`. Keep it in that type as long as you're just moving it between +stable containers. Only unwrap with `to_linear_value` when you genuinely need +to inspect or compute with the raw value. + +### Pattern 2: Use `Maybe.of_stable` / `Maybe.to_stable` to reorder wrappers + +Stable container iterators provide `'v Stable.t`, but sometimes you need +`'v Stable.t Maybe.t` (e.g., after `StableMap.find_maybe`). The `Maybe` module +provides zero-allocation conversions: + +```ocaml +(* StableWave stores ('k, 'v Maybe.t) — so push needs 'v Maybe.t Stable.t *) +(* StableMap.find_maybe returns 'v Stable.t Maybe.t *) + +(* Reorder: 'v Stable.t Maybe.t → 'v Maybe.t Stable.t *) +let mv_stable = Maybe.to_stable (Maybe.some v) (* v : 'v Stable.t *) + +(* Reorder: 'v Maybe.t Stable.t → 'v Stable.t Maybe.t *) +let mv = Maybe.of_stable mv_stable +``` + +### Pattern 3: Change callback signatures to accept `Stable.t` + +**Before (violation in the module):** +```ocaml +type ('k, 'v) t = { + merge: 'v -> 'v -> 'v; (* raw values *) + ... +} + +(* Every merge call requires unwrap + rewrap *) +let merged = t.merge (Stable.to_linear_value a) (Stable.to_linear_value b) in +StableMap.replace t.target k (Stable.unsafe_of_value merged) +``` + +**After (safe):** +```ocaml +type ('k, 'v) t = { + merge: 'v Stable.t -> 'v Stable.t -> 'v Stable.t; (* stable values *) + ... +} + +(* No conversion needed *) +let merged = t.merge a b in +StableMap.replace t.target k merged +``` + +This pushes the `unsafe_of_value` to the boundary where the callback is created. + +### Pattern 4: Eliminate pointless round-trips + +When `Reactive.iter` or `StableMap.iter_with` provides `'k Stable.t` and +`'v Stable.t`, and the callback just passes them to another stable API, don't +unwrap and rewrap: + +**Before (pointless round-trip):** +```ocaml +StableMap.iter_with + (fun wave k v -> + StableWave.push wave k + (Stable.unsafe_of_value (Stable.to_linear_value v))) + output_wave pending +``` + +**After (direct pass-through):** +```ocaml +StableMap.iter_with + (fun wave k v -> StableWave.push wave k v) + output_wave pending +``` + +## Pushing the boundary outward + +When an inner module becomes stable-safe, the `unsafe_of_value` calls don't +disappear — they move to the next layer out. This is the right trade-off: + +1. **Inner modules** (e.g., `ReactiveUnion`, `Reactive.ml`) become provably + safe. They cannot corrupt stable storage regardless of what the caller does, + as long as the `Stable.t` types in their API are respected. + +2. **Boundary callers** (e.g., `ReactiveTypeDeps.ml`, `ReactiveLiveness.ml`) + wrap user-provided functions to bridge raw ↔ stable: + + ```ocaml + Reactive.Union.create ~name:"u1" left right + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () + ``` + +3. **The ideal boundary** is where values are first introduced into the stable + world — typically at `Source.emit` or initial population. At that point + `unsafe_of_value` (or the checked `of_value`) is unavoidable and correct. + +## Current status + +**Stable-safe (zero `unsafe_of_value`):** +- `ReactiveUnion.ml` — merge signature takes `'v Stable.t` +- `Reactive.ml` — Source, Union, FlatMap, Join, Fixpoint wrappers + +**Boundary (callers responsible for `unsafe_of_value`):** +- `ReactiveTypeDeps.ml`, `ReactiveLiveness.ml`, `ReactiveDeclRefs.ml`, + `ReactiveExceptionRefs.ml`, `ReactiveMerge.ml` — Union merge functions +- `ReactiveSolver.ml` — `Reactive.get` calls with `unsafe_of_value` on keys + +**Non-linear reads (`unsafe_to_nonlinear_value`) — audit surface:** +- `ReactiveMerge.ml` freeze functions — copy stable → OCaml-heap hashtables +- `ReactiveSolver.ml` collect_issues — accumulate issues into ref lists +- `DeclarationStore.ml` find_opt/fold/iter — return or pass values to callers +- `Reanalyze.ml` find_decl — return value to caller + +## Reference: ReactiveUnion → Reactive.ml as a worked example + +`ReactiveUnion` was made fully stable-safe by: + +1. Changing `merge: 'v -> 'v -> 'v` → `merge: 'v Stable.t -> 'v Stable.t -> 'v Stable.t` + (eliminated 3 `unsafe_of_value` calls at merge sites) + +2. Keeping `'k Stable.t` from `iter_with` callbacks instead of unwrapping + (eliminated ~20 `unsafe_of_value` calls for keys passed between containers) + +3. Using `Maybe.of_stable` / `Maybe.to_stable` to convert between + `'v Stable.t Maybe.t` and `'v Maybe.t Stable.t` without allocation + (eliminated unwrap/rewrap pairs around maybe-values) + +Then `Reactive.ml` was made stable-safe by: + +4. Pushing `Union.create`'s `?merge` signature to accept `'v Stable.t` + (moved wrapping to callers in `reanalyze/`) + +5. Removing 3 pointless round-trips in `Source` (iter, get, pending→wave) + where values were unwrapped and immediately rewrapped + +6. Rewriting `Source.apply_emit` with `Maybe.of_stable`/`Maybe.to_stable` + instead of unwrap/rewrap through `to_linear_value`/`unsafe_of_value` + +## Checklist for making a module stable-safe + +- [ ] `grep unsafe_of_value` — list all occurrences +- [ ] For each: is the value already `Stable.t` upstream? If so, thread it through +- [ ] For callback fields: change signature to accept/return `Stable.t` +- [ ] For `Maybe` wrapper reordering: use `Maybe.of_stable` / `Maybe.to_stable` +- [ ] For pointless round-trips: remove the unwrap/rewrap pair entirely +- [ ] After changes: verify zero `unsafe_of_value` remains +- [ ] Build and run tests (especially allocation tests — zero words/iter) +- [ ] Verify the `unsafe_of_value` moved to the appropriate boundary layer +- [ ] Audit all `to_linear_value` in changed code — use `unsafe_to_nonlinear_value` for non-linear uses diff --git a/analysis/reactive/experiments/hyperindex_replay_build_times.sh b/analysis/reactive/experiments/hyperindex_replay_build_times.sh index 4b6485749c..ea8f73364a 100755 --- a/analysis/reactive/experiments/hyperindex_replay_build_times.sh +++ b/analysis/reactive/experiments/hyperindex_replay_build_times.sh @@ -6,14 +6,110 @@ START_REF="benchmark/rescript-baseline" END_REF="benchmark/rescript-followup" HYPERINDEX_REPO="/Users/cristianocalcagno/GitHub/hyperindex" OUT_DIR="${OUT_DIR:-/tmp/hyperindex-replay-times-refs}" +MAX_STEPS="${MAX_STEPS:-0}" +REACTIVE_ONLY=0 SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)" +SCRIPT_NAME="$0" RESCRIPT_REPO="$(cd "$SCRIPT_DIR/../../.." && pwd)" TOOLS_BIN="$RESCRIPT_REPO/_build/default/tools/bin/main.exe" SOCKET_FILE="$HYPERINDEX_REPO/.rescript-reanalyze.sock" -SERVER_LOG="$OUT_DIR/reactive-server.log" SERVER_PID="" FIXPOINT_ASSERT="${FIXPOINT_ASSERT:-1}" FIXPOINT_METRICS="${FIXPOINT_METRICS:-1}" +ALLOC_TRACE_FILE="${ALLOC_TRACE_FILE:-/tmp/rescript-reactive-alloc-events.log}" + +alloc_trace_enabled() { + case "${RESCRIPT_REACTIVE_ALLOC_TRACE:-}" in + 1|2|true|TRUE|yes|YES) return 0 ;; + *) return 1 ;; + esac +} + +append_alloc_marker() { + if alloc_trace_enabled; then + local msg="$1" + printf '%s\n' "$msg" >> "$ALLOC_TRACE_FILE" + fi +} + +line_count() { + wc -l < "$1" | tr -d ' ' +} + +append_alloc_segment_summary() { + if ! alloc_trace_enabled; then + return + fi + local mode="$1" + local idx="$2" + local commit="$3" + local begin_line="$4" + local end_line="$5" + local counts + counts="$( + awk -v b="$begin_line" -v e="$end_line" ' + NR > b && NR <= e && $1 == "[ALLOC_EVT]" { + total++ + by[$2]++ + } + END { + miss = by["pool_set_miss_create"] + 0 + resize = by["pool_set_resize"] + 0 + map_miss = by["pool_map_miss_create"] + 0 + map_resize = by["pool_map_resize"] + 0 + printf "total=%d set_miss_create=%d set_pool_resize=%d map_miss_create=%d map_pool_resize=%d kinds=%d", total + 0, miss, resize, map_miss, map_resize, length(by) + }' "$ALLOC_TRACE_FILE" + )" + append_alloc_marker "[ALLOC_REQ_SUMMARY] mode=${mode} idx=${idx} commit=${commit} ${counts}" +} + +usage() { + cat <&2 + exit 1 + fi + OUT_DIR="$2" + shift 2 + ;; + --max-steps) + if [[ $# -lt 2 ]]; then + echo "missing value for --max-steps" >&2 + exit 1 + fi + MAX_STEPS="$2" + shift 2 + ;; + --reactive-only) + REACTIVE_ONLY=1 + shift + ;; + --help|-h) + usage + exit 0 + ;; + *) + echo "unknown argument: $1" >&2 + usage >&2 + exit 1 + ;; + esac +done + +SERVER_LOG="$OUT_DIR/reactive-server.log" mkdir -p "$OUT_DIR" @@ -66,12 +162,19 @@ COMMITS=(${(@f)$(git rev-list --first-parent --reverse "$START_REF..$END_REF")}) TOTAL=${#COMMITS[@]} SUMMARY="$OUT_DIR/summary.tsv" -echo -e "idx\tcommit\tbuild_status\tbuild_real_seconds\treactive_status\treactive_real_seconds\treactive_issue_count\tcold_status\tcold_real_seconds\treactive_vs_cold_pct\tchanged_files\tinsertions\tdeletions" > "$SUMMARY" +COMMITS_FILE="$OUT_DIR/commits.txt" +RUN_META_FILE="$OUT_DIR/run_meta.txt" +echo -e "idx\tcommit\tbuild_status\tbuild_real_seconds\treactive_status\treactive_real_seconds\treactive_issue_count\tcold_status\tcold_real_seconds\treactive_vs_cold_pct\tcompare_status\tcompare_diff_count\tchanged_files\tinsertions\tdeletions" > "$SUMMARY" echo "Starting reactive server with debug assertions..." rm -f "$SOCKET_FILE" "$SERVER_LOG" +if alloc_trace_enabled; then + rm -f "$ALLOC_TRACE_FILE" + append_alloc_marker "[ALLOC_PHASE_BEGIN] phase=startup" +fi RESCRIPT_REACTIVE_FIXPOINT_ASSERT="$FIXPOINT_ASSERT" \ RESCRIPT_REACTIVE_FIXPOINT_METRICS="$FIXPOINT_METRICS" \ +RESCRIPT_REACTIVE_ALLOC_TRACE_FILE="$ALLOC_TRACE_FILE" \ "$TOOLS_BIN" reanalyze-server >"$SERVER_LOG" 2>&1 & SERVER_PID=$! @@ -87,8 +190,40 @@ if [[ ! -S "$SOCKET_FILE" ]]; then cat "$SERVER_LOG" >&2 exit 1 fi +if alloc_trace_enabled; then + append_alloc_marker "[ALLOC_PHASE_END] phase=startup" +fi echo "Replay start: $START_REF..$END_REF ($TOTAL commits)" +if alloc_trace_enabled; then + echo "Alloc trace file: $ALLOC_TRACE_FILE" +fi +if [[ "$REACTIVE_ONLY" -eq 1 ]]; then + echo "Mode: reactive-only (cold analysis + comparison disabled)" +fi + +if [[ "$MAX_STEPS" -gt 0 && "$MAX_STEPS" -lt "$TOTAL" ]]; then + COMMITS=("${COMMITS[@]:0:$MAX_STEPS}") + TOTAL=${#COMMITS[@]} + echo "Limiting replay to first $TOTAL commits (MAX_STEPS=$MAX_STEPS)" +fi + +{ + echo "start_ref=$START_REF" + echo "end_ref=$END_REF" + echo "total=$TOTAL" + echo "reactive_only=$REACTIVE_ONLY" + echo "out_dir=$OUT_DIR" + echo "alloc_trace_file=$ALLOC_TRACE_FILE" + echo "generated_at_utc=$(date -u '+%Y-%m-%dT%H:%M:%SZ')" +} > "$RUN_META_FILE" + +: > "$COMMITS_FILE" +idx_tmp=0 +for c in $COMMITS; do + idx_tmp=$((idx_tmp+1)) + echo -e "${idx_tmp}\t${c}" >> "$COMMITS_FILE" +done idx=0 for c in $COMMITS; do @@ -142,14 +277,27 @@ for c in $COMMITS; do fi if [[ "$build_status" != "ok" ]]; then - echo -e "${idx}\t${c}\t${build_status}\t${build_real}\tskipped\tNA\tNA\tskipped\tNA\tNA\t${changed_files}\t${insertions}\t${deletions}" >> "$SUMMARY" + echo -e "${idx}\t${c}\t${build_status}\t${build_real}\tskipped\tNA\tNA\tskipped\tNA\tNA\tskipped\tNA\t${changed_files}\t${insertions}\t${deletions}" >> "$SUMMARY" echo "stop: commit $c build_status=$build_status" >&2 exit 2 fi set +e + append_alloc_marker "[ALLOC_REQ_BEGIN] mode=reactive idx=${idx} commit=${c}" + if alloc_trace_enabled; then + reactive_begin_line="$(line_count "$ALLOC_TRACE_FILE")" + else + reactive_begin_line=0 + fi /usr/bin/time -p "$TOOLS_BIN" reanalyze -json >"$REACTIVE_JSON" 2>"$REACTIVE_TIME_LOG" reactive_rc=$? + if alloc_trace_enabled; then + reactive_end_line="$(line_count "$ALLOC_TRACE_FILE")" + else + reactive_end_line=0 + fi + append_alloc_segment_summary "reactive" "$idx" "$c" "$reactive_begin_line" "$reactive_end_line" + append_alloc_marker "[ALLOC_REQ_END] mode=reactive idx=${idx} commit=${c} rc=${reactive_rc}" set -e reactive_real="$(awk '/^real / {print $2}' "$REACTIVE_TIME_LOG" | tail -n 1)" @@ -165,24 +313,42 @@ for c in $COMMITS; do fi if [[ "$reactive_status" != "ok" ]]; then - echo -e "${idx}\t${c}\t${build_status}\t${build_real}\t${reactive_status}\t${reactive_real}\t${reactive_issues}\tskipped\tNA\tNA\t${changed_files}\t${insertions}\t${deletions}" >> "$SUMMARY" + echo -e "${idx}\t${c}\t${build_status}\t${build_real}\t${reactive_status}\t${reactive_real}\t${reactive_issues}\tskipped\tNA\tNA\tskipped\tNA\t${changed_files}\t${insertions}\t${deletions}" >> "$SUMMARY" echo "stop: commit $c reactive_status=$reactive_status" >&2 echo "server log: $SERVER_LOG" >&2 exit 3 fi - set +e - /usr/bin/time -p env RESCRIPT_REANALYZE_NO_SERVER=1 "$TOOLS_BIN" reanalyze -json >"$COLD_JSON" 2>"$COLD_TIME_LOG" - cold_rc=$? - set -e + if [[ "$REACTIVE_ONLY" -eq 1 ]]; then + cold_status="skipped" + cold_real="NA" + else + set +e + append_alloc_marker "[ALLOC_REQ_BEGIN] mode=cold idx=${idx} commit=${c}" + if alloc_trace_enabled; then + cold_begin_line="$(line_count "$ALLOC_TRACE_FILE")" + else + cold_begin_line=0 + fi + /usr/bin/time -p env RESCRIPT_REANALYZE_NO_SERVER=1 RESCRIPT_REACTIVE_ALLOC_TRACE_FILE="$ALLOC_TRACE_FILE" "$TOOLS_BIN" reanalyze -json >"$COLD_JSON" 2>"$COLD_TIME_LOG" + cold_rc=$? + if alloc_trace_enabled; then + cold_end_line="$(line_count "$ALLOC_TRACE_FILE")" + else + cold_end_line=0 + fi + append_alloc_segment_summary "cold" "$idx" "$c" "$cold_begin_line" "$cold_end_line" + append_alloc_marker "[ALLOC_REQ_END] mode=cold idx=${idx} commit=${c} rc=${cold_rc}" + set -e - cold_real="$(awk '/^real / {print $2}' "$COLD_TIME_LOG" | tail -n 1)" - [[ -z "${cold_real:-}" ]] && cold_real="NA" + cold_real="$(awk '/^real / {print $2}' "$COLD_TIME_LOG" | tail -n 1)" + [[ -z "${cold_real:-}" ]] && cold_real="NA" - if [[ $cold_rc -eq 0 ]]; then - cold_status="ok" - else - cold_status="fail($cold_rc)" + if [[ $cold_rc -eq 0 ]]; then + cold_status="ok" + else + cold_status="fail($cold_rc)" + fi fi if [[ "$cold_status" == "ok" && "$reactive_real" != "NA" && "$cold_real" != "NA" ]]; then @@ -191,12 +357,59 @@ for c in $COMMITS; do reactive_vs_cold_pct="NA" fi - echo -e "${idx}\t${c}\t${build_status}\t${build_real}\t${reactive_status}\t${reactive_real}\t${reactive_issues}\t${cold_status}\t${cold_real}\t${reactive_vs_cold_pct}\t${changed_files}\t${insertions}\t${deletions}" >> "$SUMMARY" + if [[ "$reactive_status" == "ok" && "$cold_status" == "ok" ]]; then + set +e + compare_out="$(python3 - "$REACTIVE_JSON" "$COLD_JSON" <<'PY' +import json, sys +from collections import Counter + +reactive_path, cold_path = sys.argv[1], sys.argv[2] +reactive = json.load(open(reactive_path)) +cold = json.load(open(cold_path)) + +def canonical_multiset(x): + if isinstance(x, list): + return Counter(json.dumps(e, sort_keys=True, separators=(",", ":")) for e in x) + return Counter([json.dumps(x, sort_keys=True, separators=(",", ":"))]) + +r = canonical_multiset(reactive) +c = canonical_multiset(cold) +if r == c: + print("equal 0") +else: + diff = 0 + keys = set(r) | set(c) + for k in keys: + diff += abs(r.get(k, 0) - c.get(k, 0)) + print(f"mismatch {diff}") +PY +)" + compare_rc=$? + set -e + if [[ $compare_rc -eq 0 ]]; then + compare_status="$(echo "$compare_out" | awk '{print $1}')" + compare_diff_count="$(echo "$compare_out" | awk '{print $2}')" + [[ -z "${compare_status:-}" ]] && compare_status="error" + [[ -z "${compare_diff_count:-}" ]] && compare_diff_count="NA" + else + compare_status="error" + compare_diff_count="NA" + fi + else + compare_status="skipped" + compare_diff_count="NA" + fi - if [[ "$cold_status" != "ok" ]]; then + echo -e "${idx}\t${c}\t${build_status}\t${build_real}\t${reactive_status}\t${reactive_real}\t${reactive_issues}\t${cold_status}\t${cold_real}\t${reactive_vs_cold_pct}\t${compare_status}\t${compare_diff_count}\t${changed_files}\t${insertions}\t${deletions}" >> "$SUMMARY" + + if [[ "$cold_status" != "ok" && "$cold_status" != "skipped" ]]; then echo "stop: commit $c cold_status=$cold_status" >&2 exit 4 fi + if [[ "$REACTIVE_ONLY" -eq 0 && "$compare_status" != "equal" ]]; then + echo "stop: commit $c compare_status=$compare_status diff=$compare_diff_count" >&2 + exit 5 + fi done stop_server diff --git a/analysis/reactive/src/Allocator.ml b/analysis/reactive/src/Allocator.ml new file mode 100644 index 0000000000..4aabd10b2f --- /dev/null +++ b/analysis/reactive/src/Allocator.ml @@ -0,0 +1,100 @@ +external slot_size_bytes_unsafe : unit -> int + = "caml_reactive_allocator_slot_size_bytes" +[@@noalloc] +external live_block_count : unit -> int + = "caml_reactive_allocator_live_block_count" +[@@noalloc] + +external live_block_capacity_slots : unit -> int + = "caml_reactive_allocator_live_block_capacity_slots" +[@@noalloc] +external reset : unit -> unit = "caml_reactive_allocator_reset" [@@noalloc] +external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" +[@@noalloc] + +let check_non_negative name n = if n < 0 then invalid_arg name + +let slot_size_bytes = slot_size_bytes_unsafe () + +module Block = struct + type 'a t = int + + external create_unsafe : int -> 'a t = "caml_reactive_allocator_create" + [@@noalloc] + + external destroy : 'a t -> unit = "caml_reactive_allocator_destroy" + [@@noalloc] + + external capacity : 'a t -> int = "caml_reactive_allocator_capacity" + [@@noalloc] + + external resize_unsafe : 'a t -> int -> unit + = "caml_reactive_allocator_resize" + [@@noalloc] + + external unsafe_get : 'a t -> int -> 'a Stable.t + = "caml_reactive_allocator_get" + [@@noalloc] + + external unsafe_set : 'a t -> int -> 'a Stable.t -> unit + = "caml_reactive_allocator_set" + [@@noalloc] + + external blit_unsafe : 'a t -> int -> 'a t -> int -> int -> unit + = "caml_reactive_allocator_blit" + [@@noalloc] + + let create ~capacity = + check_non_negative "Allocator.Block.create" capacity; + create_unsafe capacity + + let resize block ~capacity = + check_non_negative "Allocator.Block.resize" capacity; + resize_unsafe block capacity + + let get block index = + let cap = capacity block in + if index < 0 || index >= cap then invalid_arg "Allocator.Block.get"; + unsafe_get block index + + let set block index value = + let cap = capacity block in + if index < 0 || index >= cap then invalid_arg "Allocator.Block.set"; + unsafe_set block index value + + let blit ~src ~src_pos ~dst ~dst_pos ~len = + check_non_negative "Allocator.Block.blit" src_pos; + check_non_negative "Allocator.Block.blit" dst_pos; + check_non_negative "Allocator.Block.blit" len; + let src_cap = capacity src in + let dst_cap = capacity dst in + if src_pos + len > src_cap || dst_pos + len > dst_cap then + invalid_arg "Allocator.Block.blit"; + blit_unsafe src src_pos dst dst_pos len +end + +module Block2 = struct + type ('a, 'x, 'y) t = 'a Block.t + + let header_slots = 2 + + let create ~capacity ~x0 ~y0 = + let t = Block.create ~capacity:(capacity + header_slots) in + Block.set t 0 (Stable.unsafe_of_value x0); + Block.set t 1 (Stable.unsafe_of_value y0); + t + + let destroy = Block.destroy + let capacity t = Block.capacity t - header_slots + let resize t ~capacity = Block.resize t ~capacity:(capacity + header_slots) + let get0 t = Stable.to_linear_value (Block.get t 0) + let set0 t x = Block.set t 0 (Stable.unsafe_of_value x) + let get1 t = Stable.to_linear_value (Block.get t 1) + let set1 t y = Block.set t 1 (Stable.unsafe_of_value y) + let get t index = Block.get t (index + header_slots) + let set t index value = Block.set t (index + header_slots) value + + let blit ~src ~src_pos ~dst ~dst_pos ~len = + Block.blit ~src ~src_pos:(src_pos + header_slots) ~dst + ~dst_pos:(dst_pos + header_slots) ~len +end diff --git a/analysis/reactive/src/Allocator.mli b/analysis/reactive/src/Allocator.mli new file mode 100644 index 0000000000..3af9ef0e67 --- /dev/null +++ b/analysis/reactive/src/Allocator.mli @@ -0,0 +1,100 @@ +(** Stable storage for raw OCaml values. + + Main concepts: + - A [block] is a stable buffer managed by the allocator. + - A block contains a number of [slots]. + - Each slot stores one raw OCaml [value] word. + - Block [capacity] is measured in slots; byte counts are derived from that. + + This allocator does not participate in GC scanning. Storing a heap value in + a block is therefore only safe if the value: + - is not in the minor heap, and + - remains reachable through ordinary OCaml roots elsewhere. + + Immediates such as [int] are always safe to store. Use {!Stable} to mark + values that cross into stable containers. *) + +module Block : sig + type 'a t + + val create : capacity:int -> 'a t + (** Allocate a stable block of raw OCaml value slots. *) + + val destroy : 'a t -> unit + (** Release the block storage. The handle must not be used afterwards. *) + + val capacity : 'a t -> int + (** Current block size, in slots. *) + + val resize : 'a t -> capacity:int -> unit + (** Resize the block, preserving the prefix up to the new capacity. *) + + val get : 'a t -> int -> 'a Stable.t + (** Read a slot. The caller is responsible for keeping pointed-to values + alive and out of the minor heap while stored stable. *) + + val set : 'a t -> int -> 'a Stable.t -> unit + (** Write a slot. *) + + val blit : + src:'a t -> src_pos:int -> dst:'a t -> dst_pos:int -> len:int -> unit + (** Copy a range of raw value slots between blocks. *) +end + +module Block2 : sig + type ('a, 'x, 'y) t + + val create : capacity:int -> x0:'x -> y0:'y -> ('a, 'x, 'y) t + (** Allocate a stable block with two typed header slots followed by + [capacity] data slots. *) + + val destroy : ('a, 'x, 'y) t -> unit + (** Release the block storage. The handle must not be used afterwards. *) + + val capacity : ('a, 'x, 'y) t -> int + (** Current data capacity, in slots, excluding the two header slots. *) + + val resize : ('a, 'x, 'y) t -> capacity:int -> unit + (** Resize the data region, preserving the two header slots and the data + prefix up to the new capacity. *) + + val get0 : ('a, 'x, 'y) t -> 'x + val set0 : ('a, 'x, 'y) t -> 'x -> unit + val get1 : ('a, 'x, 'y) t -> 'y + val set1 : ('a, 'x, 'y) t -> 'y -> unit + + val get : ('a, 'x, 'y) t -> int -> 'a Stable.t + (** Read a data slot. *) + + val set : ('a, 'x, 'y) t -> int -> 'a Stable.t -> unit + (** Write a data slot. *) + + val blit : + src:('a, 'x, 'y) t -> + src_pos:int -> + dst:('a, 'u, 'v) t -> + dst_pos:int -> + len:int -> + unit + (** Copy data slots between blocks, excluding header slots. *) +end + +val slot_size_bytes : int +(** Size in bytes of one stored raw OCaml value slot. *) + +val live_block_count : unit -> int +(** Number of currently live allocator blocks. *) + +val live_block_capacity_slots : unit -> int +(** Total payload capacity, in slots, across all live blocks. *) + +val reset : unit -> unit +(** Release all allocator blocks. + + Intended for tests. Any existing block or wave handles become invalid after + this call. *) + +val is_in_minor_heap : 'a -> bool +(** Runtime check for whether a value currently resides in the OCaml minor + heap. Immediates return [false]. Useful for enforcing the stable storage + invariant in tests and debug code. *) diff --git a/analysis/reactive/src/CONVERTING_COMBINATORS.md b/analysis/reactive/src/CONVERTING_COMBINATORS.md new file mode 100644 index 0000000000..dc132bbe22 --- /dev/null +++ b/analysis/reactive/src/CONVERTING_COMBINATORS.md @@ -0,0 +1,356 @@ +# Converting Reactive Combinators to Zero-Allocation Modules + +This document describes how to extract a reactive combinator from +`Reactive.ml` into its own private module backed by `ReactiveHash` +(Hachis open-addressing tables), following the pattern established +by `ReactiveUnion` and `ReactiveFlatMap`. + +## Best Practices for Zero-Allocation Code + +Lessons learned from converting combinators to zero-allocation: + +### What allocates in OCaml + +Verified with assembly inspection (`ocamlfind ocamlopt -S`) and +`Gc.stat()` measurement (see `ClosureAllocTest.ml`). + +**Closures that capture variables always allocate.** The compiler +lifts the function *code* to a static top-level function, but still +heap-allocates a closure *record* (environment block) every time the +closure is created, to pair the code pointer with captured variables. +A closure capturing N variables costs N+3 words (header + code ptr + +arity info + N env slots). + +``` +one closure (captures 1 param): 4 words +two closures (capture 1 param each): 8 words +closure + ref (captures ref + param): 7 words (ref=2 + closure=5) +no closure (passes value directly): 0 words +``` + +**Non-capturing closures are free.** The compiler lifts them to +static constants — `Map.iter (fun _k _v -> ()) m` allocates 0 words. + +**Capturing a function parameter still costs 4 words.** +`let f k = Array.length t + k in use f` allocates even though `t` is +just a function parameter — the runtime needs a closure record to +bundle the code pointer with `t`. + +**Refs that escape into closures allocate** (2 words: header + value). +`let count = ref 0 in let f k = incr count; ... in` — the `ref` +is heap-allocated because it escapes into the closure. + +**Refs that do NOT escape are free.** When a `ref` is only used in +straight-line code (not captured by any closure), the compiler +unboxes it into a local mutable — zero allocation. + +**Higher-order function arguments create closures at call sites.** +Each function argument that captures variables costs a closure record +at the call site. + +### Pass data directly instead of wrapping it in closures + +When a function takes a higher-order argument just to abstract over +how data is accessed, but there is only one implementation, pass the +data directly and call the concrete function at the point of use. + +```ocaml +(* Before: 13 words — 3 closure records allocated at call site *) +let apply_list t ~init_iter ~edge_iter ~emit_entry = ... +apply_list t + ~init_iter:(fun f -> ReactiveWave.iter roots f) + ~edge_iter:(fun f -> ReactiveWave.iter edges f) + ~emit_entry:(fun k v -> ReactiveWave.push t.output_wave k v) + +(* After: 0 words — data passed directly, concrete calls at use site *) +let apply_list t ~roots ~edges = ... +apply_list t ~roots ~edges +``` + +### Lift local helpers to module-level functions + +A local `let f k = ... t ... in` captures `t` and allocates a +closure. Moving it to `let f t k = ...` at module level eliminates +the closure. When passing it to debug-only callbacks, guard with +`if Invariants.enabled` so the partial application `(f t)` is +never allocated on the hot path. + +### Use `iter_with` and `list_iter_with` on hot paths + +When a module-level function `f t k` is passed to an iterator, +both `iter (f t)` and `iter (fun k -> f t k)` allocate a closure +capturing `t`. Use the `_with` variants to pass `t` as data: + +```ocaml +(* Allocates a closure capturing t: *) +ReactiveHash.Map.iter (fun k () -> enqueue t k) m +List.iter (fun k -> mark_deleted t k) succs + +(* Zero allocation — t passed as data: *) +ReactiveHash.Map.iter_with enqueue_kv t m +list_iter_with mark_deleted t succs +``` + +`iter_with f arg t` calls `f arg k v` directly, where `f` is a +static top-level function (no closure record needed). Available on +`ReactiveHash.Map`, `ReactiveHash.Set`, `ReactiveWave`, and as +`list_iter_with` for `'a list`. + +### Use `Maybe` instead of `option` for lookups + +`ReactiveHash.Map.find_maybe` returns a `Maybe.t` — an +unboxed optional that avoids allocating `Some`. Use this instead of +`find_opt` in hot paths: + +```ocaml +(* Zero allocation: *) +let r = ReactiveHash.Map.find_maybe t.pred_map k in +if Maybe.is_some r then + use (Maybe.unsafe_get r) + +(* Allocates Some on hit: *) +match ReactiveHash.Map.find_opt t.pred_map k with +| Some v -> use v +| None -> ... +``` + +### Use `Map.has_common_key` for set intersection tests + +When checking whether any key in map A exists in map B (e.g. +"does this node have a live predecessor?"), use the dedicated +`has_common_key` instead of `iter` + exception: + +```ocaml +(* Zero allocation, early-exit: *) +ReactiveHash.Map.has_common_key pred_set current + +(* Allocates 5 words/call due to capturing closure: *) +try + ReactiveHash.Map.iter (fun k () -> + if ReactiveHash.Map.mem current k then raise Found) pred_set; + false +with Found -> true +``` + +### `Obj.magic` for type-erased iteration + +`ReactiveHash` stores `Obj.t` internally. The `iter` implementation +uses `Obj.magic f` to cast the user's typed callback directly, +avoiding a wrapper closure that would allocate 10 words per call: + +```ocaml +(* Zero allocation — Obj.magic casts without wrapping: *) +let iter f t = table_iter_kv (Obj.magic f) t + +(* 10 words/call — wrapper closure allocates: *) +let iter f t = table_iter_kv (fun k v -> f (Obj.obj k) (Obj.obj v)) t +``` + +This is safe because we never mix types within a single table +instance. + +### `unit option` is already unboxed + +OCaml represents `Some ()` identically to `()` at runtime — no +allocation. Switching `unit option` to `Maybe.t` does not +save allocations (confirmed by measurement). Focus optimization +effort on closures and non-unit option types instead. + +### Use `StableQueue` for BFS/worklist patterns + +Stable FIFOs (`StableQueue`) eliminate cons-cell +allocation from worklist patterns. Clear + push cycles reuse the +backing array at steady state. + +### Measure, don't guess + +Use `Gc.stat().minor_words` before/after to measure actual +allocation. Test at multiple sizes (n=10, 100, 1000) to distinguish +constant overhead from per-element allocation. See `AllocTest.ml` +for the pattern. + +**Measurement rules:** +- `Gc.stat()` itself allocates a record — never call it inside + measured code. Measure from outside only: + ```ocaml + let before = Gc.stat () in + for _ = 1 to n do f () done; + let after = Gc.stat () in + ``` +- Measure the actual code, not "similar" code — similar code can + lead to red herrings due to compiler optimization differences. +- Use `stop_after_phase` to truncate execution at phase boundaries + and measure cumulative allocation up to each point. +- Verify with assembly (`ocamlfind ocamlopt -S ...`) — look for + `sub x27, x27, #N` (bump-pointer allocation on ARM64) inside + the function. Count bytes / 8 = words. + +## Why + +`Stdlib.Hashtbl` uses chaining (linked-list buckets). Every +`clear` + `replace` cycle allocates fresh `Cons` cells on the heap. +For combinators whose `process()` runs on every scheduler wave, this +means O(n) allocations per wave just for internal bookkeeping. + +`ReactiveHash` wraps Hachis, which uses open addressing with flat +arrays. After the table reaches steady-state capacity, `clear` + +`replace` reuses existing array slots — zero heap allocation. + +## Step-by-step + +### 1. Create the private module files + +Create `Reactive.ml` and `Reactive.mli` in +`analysis/reactive/src/`. + +Add the module to `private_modules` in +`analysis/reactive/src/dune` (alongside `ReactiveFixpoint`, +`ReactiveFlatMap`, `ReactiveUnion`). + +### 2. Define a state type and `process_result` + +The state record holds all persistent tables and scratch buffers. +Use `ReactiveHash.Map` for key-value maps and `ReactiveHash.Set` +for dedup sets. + +```ocaml +type ('k, 'v) t = { + (* persistent state *) + target: ('k, 'v) ReactiveHash.Map.t; + ... + (* scratch — allocated once, cleared per process() *) + scratch: ('k, 'v option) ReactiveHash.Map.t; + affected: 'k ReactiveHash.Set.t; + (* pre-allocated output buffer *) + output_wave: ('k, 'v option) ReactiveWave.t; +} +``` + +`process_result` carries stats deltas back to the caller (avoids +a dependency on `Reactive.stats`): + +```ocaml +type process_result = { + entries_received: int; + adds_received: int; + removes_received: int; + entries_emitted: int; + adds_emitted: int; + removes_emitted: int; +} +``` + +### 3. Implement `push`, `process`, `init_*`, and target accessors + +- **`push`**: called from the subscribe callback. Writes directly + into the scratch map (last-write-wins dedup is automatic). +- **`process`**: clears scratch and affected set, applies updates, + recomputes affected keys, writes directly to `output_wave`. + Returns `process_result`. No intermediate lists. +- **`init_*`**: called during setup to populate persistent state + from existing upstream data (before subscriptions fire). +- **`iter_target`**, **`find_target`**, **`target_length`**: expose + read access to the output state for the `('k, 'v) t` record. + +### 4. Rewrite the combinator in `Reactive.ml` + +The combinator function in `Reactive.ml` becomes a thin wiring +layer: + +```ocaml +let my_combinator ~name ... = + let state = ReactiveMyCombinator.create ~... ~output_wave in + let pending_count = ref 0 in (* one per input edge *) + + let process () = + (* snapshot + reset pending counts *) + (* dec_inflight for each input edge *) + let r = ReactiveMyCombinator.process state in + (* apply r.* to my_stats *) + (* if r.entries_emitted > 0: notify subscribers *) + in + + (* Registry.register, add_edge, add_combinator *) + + (* Subscribe: push into scratch, incr pending_count *) + src.subscribe (fun wave -> + Registry.inc_inflight ...; + incr pending_count; + ReactiveWave.iter wave (fun k v_opt -> + ReactiveMyCombinator.push state k v_opt); + Registry.mark_dirty name); + + (* Initialize from existing data *) + src.iter (fun k v -> ReactiveMyCombinator.init_entry state k v); + + { name; subscribe; iter; get; length; stats; level } +``` + +### 5. Key patterns to follow + +**Replace per-process-call allocations:** +| Old (Hashtbl) | New (ReactiveHash) | +|--------------------------------------------|------------------------------------------| +| `pending := wave :: !pending` | `ReactiveWave.iter wave push_to_scratch` | +| `merge_wave_entries !pending` | scratch map already merged | +| `merge_entries entries` | scratch map already deduped | +| `Hashtbl.create n` for `seen` | persistent `ReactiveHash.Set`, `clear` | +| `List.filter_map ... recompute_target` | `ReactiveHash.Set.iter` + write to wave | +| `count_adds_removes entries` (list walk) | count inline with `ref` during iteration | + +**Eliminate intermediate lists:** +- `recompute_target` should write directly to `output_wave` + instead of returning `Some (k, v_opt)`. +- Fold contributions directly instead of building a values list. +- `remove_source`/`add_source` should add to the `affected` set + instead of returning key lists. + +**Things that still allocate (inherent to the algorithm):** +- User-supplied functions (`f`, `key_of`) return lists — can't + be avoided without changing the public API. +- `provenance` stores `'k list` per input key. +- Inner contribution maps are created when new output keys appear. + +### 6. Build and test + +```bash +dune build @analysis/reactive/src/all +make -C analysis/reactive test +``` + +## Appendix: Conversion Status + +### Converted + +| Combinator | Module | Notes | +|------------|-----------------------|------------------------------------------| +| `union` | `ReactiveUnion.ml` | Fully zero-alloc steady-state process() | +| `flatMap` | `ReactiveFlatMap.ml` | Zero-alloc except user `f` and provenance lists | +| `join` | `ReactiveJoin.ml` | Zero-alloc except user `f`, `key_of`, provenance lists, and reverse-index list updates | +| `fixpoint` | `ReactiveFixpoint.ml` | Zero-alloc steady-state (constant 4 words/iter regardless of n). See remaining items below | +| `source` | N/A | No internal tables — just emits deltas | + +### Remaining allocations in `ReactiveFixpoint` + +Converted to `ReactiveHash`: +- Persistent state: `current`, `edge_map`, `pred_map` (including inner pred sets), `roots` +- Per-call scratch: `deleted_nodes`, `rederive_pending`, `expansion_seen`, `old_successors_for_changed`, `new_successors_for_changed`, `edge_has_new` +- Temp sets in `process_edge_change` and `apply_edge_update` + +Converted to `StableQueue` (stable FIFO): +- 3 BFS queues: `delete_queue`, `rederive_queue`, `expansion_queue` +- 2 phase queues: `added_roots_queue`, `edge_change_queue` +- All persistent fields cleared per call, zero allocation at steady state + +Eliminated intermediate lists, records, and closures: +- `removed_roots` cons list — replaced by inline `mark_deleted` during init iteration +- `added_roots` cons list — replaced by `added_roots_queue` +- `edge_changes` cons list + `edge_change` records — replaced by `edge_change_queue` + `new_successors_for_changed` map + `edge_has_new` set +- `process_edge_change` uses callback-based `on_removed` instead of returning a `removed_targets` list +- `has_live_predecessor` capturing closure — replaced by `Map.has_common_key` (eliminated 5 words/node/iter) + +Still allocating (inherent to the algorithm or debug-only): +- **`edge_map` values** are `'k list` — list allocation is inherent when edges change. +- **`pred_map` inner maps**: new `ReactiveHash.Map` created when a node first gains predecessors (same pattern as `contributions` in flatMap/join — allocates once per new target, then reuses). +- **`compute_reachable_from_roots_with_work`**: creates a fresh `Hashtbl` for full BFS. Only called during `initialize` and in `Metrics` mode. +- **`Invariants` module**: uses `Hashtbl` for debug-only set operations (copies, diffs). Opt-in via env var — not on the hot path. diff --git a/analysis/reactive/src/Maybe.ml b/analysis/reactive/src/Maybe.ml new file mode 100644 index 0000000000..8adeecfdc5 --- /dev/null +++ b/analysis/reactive/src/Maybe.ml @@ -0,0 +1,22 @@ +(** Zero-allocation unboxed optional values. + + Internally, [none] is a physically unique sentinel object. + [some v] is just [Obj.repr v] — no allocation. + [is_some] checks physical inequality with the sentinel. *) + +type 'a t = Obj.t + +let sentinel_words = 257 +let sentinel : Obj.t = Obj.repr (Array.make sentinel_words 0) + +let none = sentinel +let none_stable = Stable.of_value none +let[@inline] some (x : 'a) : 'a t = Obj.repr x +let[@inline] is_none (x : 'a t) = x == sentinel +let[@inline] is_some (x : 'a t) = x != sentinel +let[@inline] unsafe_get (x : 'a t) : 'a = Obj.obj x +let[@inline] to_option (x : 'a t) : 'a option = + if x != sentinel then Some (Obj.obj x) else None + +let[@inline] to_stable (m : 'a Stable.t t) : 'a t Stable.t = Obj.magic m +let[@inline] of_stable (m : 'a t Stable.t) : 'a Stable.t t = Obj.magic m diff --git a/analysis/reactive/src/Maybe.mli b/analysis/reactive/src/Maybe.mli new file mode 100644 index 0000000000..a4f392b176 --- /dev/null +++ b/analysis/reactive/src/Maybe.mli @@ -0,0 +1,30 @@ +(** Zero-allocation unboxed optional values. + + An ['a t] is either [none] (a unique sentinel) or [some v]. + Unlike [option], wrapping a value with [some] performs no allocation — + it is a plain [Obj.repr] cast. + + {b Safety contract:} [get] must only be called after [is_some] returns + [true]. Calling [get] on [none] is undefined behavior. *) + +type 'a t + +val none : 'a t +(** Unique sentinel representing the absent case. *) + +val none_stable : 'a t Stable.t +(** Stable-marked form of [none]. Safe because the sentinel is allocated + outside the minor heap and kept reachable for the lifetime of the process. *) + +val some : 'a -> 'a t +val is_none : 'a t -> bool +val is_some : 'a t -> bool +val unsafe_get : 'a t -> 'a + +val to_option : 'a t -> 'a option + +val to_stable : 'a Stable.t t -> 'a t Stable.t +(** Reorder [Stable.t] outside [Maybe.t]. Zero allocation. *) + +val of_stable : 'a t Stable.t -> 'a Stable.t t +(** Reorder [Stable.t] inside [Maybe.t]. Zero allocation. *) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 9db201901d..27f79d54ae 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -1,47 +1,23 @@ (** Reactive V2: Accumulate-then-propagate scheduler for glitch-free semantics. - + Key design: 1. Nodes accumulate batch deltas (don't process immediately) 2. Scheduler visits nodes in dependency order 3. Each node processes accumulated deltas exactly once per wave - - This eliminates glitches from multi-level dependencies. *) - -(** {1 Deltas} *) - -type ('k, 'v) delta = - | Set of 'k * 'v - | Remove of 'k - | Batch of ('k * 'v option) list -let set k v = (k, Some v) -let remove k = (k, None) + This eliminates glitches from multi-level dependencies. *) -let delta_to_entries = function - | Set (k, v) -> [(k, Some v)] - | Remove k -> [(k, None)] - | Batch entries -> entries +(** {1 Waves} *) -let merge_entries entries = - (* Deduplicate: later entries win *) - let tbl = Hashtbl.create (List.length entries) in - List.iter (fun (k, v) -> Hashtbl.replace tbl k v) entries; - Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] +type ('k, 'v) wave = ('k, 'v Maybe.t) StableWave.t -let count_adds_removes entries = - List.fold_left - (fun (adds, removes) (_, v) -> - match v with - | Some _ -> (adds + 1, removes) - | None -> (adds, removes + 1)) - (0, 0) entries +let create_wave () = StableWave.create () (** {1 Statistics} *) type stats = { (* Input tracking *) - mutable deltas_received: int; - (** Number of delta messages (Set/Remove/Batch) *) + mutable deltas_received: int; (** Number of delta messages (Batch) *) mutable entries_received: int; (** Total entries after expanding batches *) mutable adds_received: int; (** Set operations received from upstream *) mutable removes_received: int; @@ -70,18 +46,6 @@ let create_stats () = removes_emitted = 0; } -(** Count adds and removes in a list of entries *) -let count_changes entries = - let adds = ref 0 in - let removes = ref 0 in - List.iter - (fun (_, v_opt) -> - match v_opt with - | Some _ -> incr adds - | None -> incr removes) - entries; - (!adds, !removes) - (** {1 Debug} *) let debug_enabled = ref false @@ -96,7 +60,9 @@ module Registry = struct mutable upstream: string list; mutable downstream: string list; mutable dirty: bool; + mutable outbound_inflight: int; process: unit -> unit; (* Process accumulated deltas *) + destroy: unit -> unit; stats: stats; } @@ -106,9 +72,16 @@ module Registry = struct (* Combinator nodes: (combinator_id, (shape, inputs, output)) *) let combinators : (string, string * string list * string) Hashtbl.t = Hashtbl.create 32 - let dirty_nodes : string list ref = ref [] - let register ~name ~level ~process ~stats = + (* Dirty-node tracking: count + per-node flag (no list, no Hashtbl) *) + let dirty_count = ref 0 + + (* Pre-sorted node array for zero-alloc propagation. + Built lazily on first propagate; invalidated by register_node. *) + let sorted_nodes : node_info array ref = ref [||] + let sorted_valid = ref true + + let register_node ~name ~level ~process ~destroy ~stats = let info = { name; @@ -116,11 +89,14 @@ module Registry = struct upstream = []; downstream = []; dirty = false; + outbound_inflight = 0; process; + destroy; stats; } in Hashtbl.replace nodes name info; + sorted_valid := false; info let add_edge ~from_name ~to_name ~label = @@ -136,18 +112,45 @@ module Registry = struct let add_combinator ~name ~shape ~inputs ~output = Hashtbl.replace combinators name (shape, inputs, output) - let mark_dirty name = - match Hashtbl.find_opt nodes name with - | Some info when not info.dirty -> + (** Zero-alloc mark_dirty: sets flag + increments counter. + Takes node_info directly — no Hashtbl lookup, no cons cell. *) + let mark_dirty_node (info : node_info) = + if not info.dirty then ( info.dirty <- true; - dirty_nodes := name :: !dirty_nodes - | _ -> () + incr dirty_count) + + (** Zero-alloc inflight tracking on node_info directly. *) + let inc_inflight_node (info : node_info) = + info.outbound_inflight <- info.outbound_inflight + 1 + + let dec_inflight_node (info : node_info) count = + if count > 0 then ( + let n = info.outbound_inflight in + if count > n then + failwith + (Printf.sprintf + "Reactive inflight underflow on node %s (count=%d, inflight=%d)" + info.name count n); + info.outbound_inflight <- n - count) + + let ensure_sorted () = + if not !sorted_valid then ( + let all = Hashtbl.fold (fun _ info acc -> info :: acc) nodes [] in + let sorted = List.sort (fun a b -> compare a.level b.level) all in + sorted_nodes := Array.of_list sorted; + sorted_valid := true) let clear () = Hashtbl.clear nodes; Hashtbl.clear edges; Hashtbl.clear combinators; - dirty_nodes := [] + dirty_count := 0; + sorted_nodes := [||]; + sorted_valid := true + + let destroy_graph () = + Hashtbl.iter (fun _ info -> info.destroy ()) nodes; + clear () let reset_stats () = Hashtbl.iter @@ -339,61 +342,34 @@ module Scheduler = struct d_int after_.process_count before.process_count, d_time after_.process_time_ns before.process_time_ns ) - (** Process all dirty nodes in level order *) + (** Process all dirty nodes in level order. + Uses pre-sorted node array — zero allocation at steady state. *) let propagate () = if !propagating then failwith "Scheduler.propagate: already propagating (nested call)" else ( propagating := true; incr wave_counter; - let wave_id = !wave_counter in - let wave_start = Unix.gettimeofday () in - let processed_nodes = ref 0 in - if !debug_enabled then + Registry.ensure_sorted (); + let nodes = !Registry.sorted_nodes in + let len = Array.length nodes in + + if !debug_enabled then ( + let wave_id = !wave_counter in + let wave_start = Unix.gettimeofday () in + let processed_nodes = ref 0 in Printf.eprintf "\n=== Reactive wave %d ===\n%!" wave_id; - while !Registry.dirty_nodes <> [] do - (* Get all dirty nodes, sort by level *) - let dirty = !Registry.dirty_nodes in - Registry.dirty_nodes := []; - - let nodes_with_levels = - dirty - |> List.filter_map (fun name -> - match Hashtbl.find_opt Registry.nodes name with - | Some info -> Some (info.Registry.level, name, info) - | None -> None) - in - - let sorted = - List.sort - (fun (l1, _, _) (l2, _, _) -> compare l1 l2) - nodes_with_levels - in - - (* Find minimum level *) - match sorted with - | [] -> () - | (min_level, _, _) :: _ -> - (* Process all nodes at minimum level *) - let at_level, rest = - List.partition (fun (l, _, _) -> l = min_level) sorted - in - - (* Put remaining back in dirty list *) - List.iter - (fun (_, name, _) -> - Registry.dirty_nodes := name :: !Registry.dirty_nodes) - rest; - - (* Process nodes at this level *) - List.iter - (fun (_, _, info) -> + while !Registry.dirty_count > 0 do + let made_progress = ref false in + for i = 0 to len - 1 do + let info = nodes.(i) in + if info.Registry.dirty && info.Registry.outbound_inflight = 0 then ( info.Registry.dirty <- false; - let before = - if !debug_enabled then Some (snapshot_stats info.stats) - else None - in + decr Registry.dirty_count; + made_progress := true; + incr processed_nodes; + let before = snapshot_stats info.Registry.stats in let start = Sys.time () in info.Registry.process (); let elapsed = Sys.time () -. start in @@ -402,765 +378,561 @@ module Scheduler = struct (Int64.of_float (elapsed *. 1e9)); info.Registry.stats.process_count <- info.Registry.stats.process_count + 1; - if !debug_enabled then ( - incr processed_nodes; - match before with - | None -> () - | Some b -> - let ( d_recv, - e_recv, - add_in, - rem_in, - d_emit, - e_emit, - add_out, - rem_out, - runs, - dt_ns ) = - diff_stats b info.Registry.stats - in - (* runs should always be 1 here, but keep the check defensive *) - if runs <> 0 then - Printf.eprintf - " %-30s (L%d): recv d/e/+/-=%d/%d/%d/%d emit \ - d/e/+/-=%d/%d/%d/%d time=%.2fms\n\ - %!" - info.Registry.name info.Registry.level d_recv e_recv - add_in rem_in d_emit e_emit add_out rem_out - (Int64.to_float dt_ns /. 1e6))) - at_level - done; - - (if !debug_enabled then - let wave_elapsed_ms = (Unix.gettimeofday () -. wave_start) *. 1000.0 in - Printf.eprintf "Wave %d: processed_nodes=%d wall=%.2fms\n%!" wave_id - !processed_nodes wave_elapsed_ms); + let ( d_recv, + e_recv, + add_in, + rem_in, + d_emit, + e_emit, + add_out, + rem_out, + runs, + dt_ns ) = + diff_stats before info.Registry.stats + in + if runs <> 0 then + Printf.eprintf + " %-30s (L%d): recv d/e/+/-=%d/%d/%d/%d emit \ + d/e/+/-=%d/%d/%d/%d time=%.2fms\n\ + %!" + info.Registry.name info.Registry.level d_recv e_recv add_in + rem_in d_emit e_emit add_out rem_out + (Int64.to_float dt_ns /. 1e6)) + done; + if (not !made_progress) && !Registry.dirty_count > 0 then + failwith + "Scheduler invariant violation: no runnable dirty node under \ + inflight gate" + done; + + let wave_elapsed_ms = (Unix.gettimeofday () -. wave_start) *. 1000.0 in + Printf.eprintf "Wave %d: processed_nodes=%d wall=%.2fms\n%!" wave_id + !processed_nodes wave_elapsed_ms) + else + (* Hot path: no debug output, no gettimeofday, no timing *) + while !Registry.dirty_count > 0 do + let made_progress = ref false in + for i = 0 to len - 1 do + let info = nodes.(i) in + if info.Registry.dirty && info.Registry.outbound_inflight = 0 then ( + info.Registry.dirty <- false; + decr Registry.dirty_count; + made_progress := true; + info.Registry.process (); + info.Registry.stats.process_count <- + info.Registry.stats.process_count + 1) + done; + if (not !made_progress) && !Registry.dirty_count > 0 then + failwith + "Scheduler invariant violation: no runnable dirty node under \ + inflight gate" + done; + propagating := false) let wave_count () = !wave_counter let reset_wave_count () = wave_counter := 0 end +(** {1 Subscriber notification — zero-alloc} *) + +(** Notify subscribers without allocating a closure. + [List.iter (fun h -> h wave) subs] allocates 4 words for the + closure capturing [wave]. This hand-unrolled version avoids that. *) +let rec notify_subscribers wave = function + | [] -> () + | [h] -> h wave + | [h1; h2] -> + h1 wave; + h2 wave + | h :: rest -> + h wave; + notify_subscribers wave rest + (** {1 Collection Interface} *) type ('k, 'v) t = { name: string; - subscribe: (('k, 'v) delta -> unit) -> unit; - iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v option; + subscribe: (('k, 'v) wave -> unit) -> unit; + iter: ('k Stable.t -> 'v Stable.t -> unit) -> unit; + get: 'k Stable.t -> 'v Stable.t Maybe.t; length: unit -> int; + destroy: unit -> unit; stats: stats; level: int; + node: Registry.node_info; } let iter f t = t.iter f let get t k = t.get k let length t = t.length () +let destroy t = t.destroy () let stats t = t.stats let level t = t.level let name t = t.name (** {1 Source Collection} *) -let source ~name () = - let tbl = Hashtbl.create 64 in - let subscribers = ref [] in - let my_stats = create_stats () in - - (* Pending deltas to propagate *) - let pending = ref [] in - - let process () = - if !pending <> [] then ( - let entries = - !pending |> List.concat_map delta_to_entries |> merge_entries - in - pending := []; - if entries <> [] then ( - let num_adds, num_removes = count_changes entries in +module Source = struct + type ('k, 'v) tables = { + tbl: ('k, 'v) StableMap.t; + pending: ('k, 'v Maybe.t) StableMap.t; + } + + let apply_emit (tables : ('k, 'v) tables) k mv = + let mv = Maybe.of_stable mv in + if Maybe.is_some mv then ( + StableMap.replace tables.tbl k (Maybe.unsafe_get mv); + StableMap.replace tables.pending k (Maybe.to_stable mv)) + else ( + StableMap.remove tables.tbl k; + StableMap.replace tables.pending k (Maybe.to_stable mv)) + + let create ~name () = + let tbl : ('k, 'v) StableMap.t = StableMap.create () in + let subscribers = ref [] in + let my_stats = create_stats () in + let output_wave = create_wave () in + (* Pending deltas: accumulated by emit, flushed by process. + Uses StableMap for zero-alloc deduplication (last-write-wins). *) + let pending : ('k, 'v Maybe.t) StableMap.t = StableMap.create () in + let tables = {tbl; pending} in + let pending_count = ref 0 in + + let process () = + let count = StableMap.cardinal pending in + if count > 0 then ( my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; - my_stats.entries_emitted <- - my_stats.entries_emitted + List.length entries; - my_stats.adds_emitted <- my_stats.adds_emitted + num_adds; - my_stats.removes_emitted <- my_stats.removes_emitted + num_removes; - let delta = Batch entries in - List.iter (fun h -> h delta) !subscribers)) - in + my_stats.entries_emitted <- my_stats.entries_emitted + count; + StableWave.clear output_wave; + StableMap.iter_with + (fun wave k v -> StableWave.push wave k v) + output_wave pending; + StableMap.clear pending; + notify_subscribers output_wave !subscribers) + else StableMap.clear pending + in - let _info = Registry.register ~name ~level:0 ~process ~stats:my_stats in + let destroy () = + StableMap.destroy tbl; + StableMap.destroy pending; + StableWave.destroy output_wave + in + let my_info = + Registry.register_node ~name ~level:0 ~process ~destroy ~stats:my_stats + in - let collection = - { - name; - subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> Hashtbl.iter f tbl); - get = (fun k -> Hashtbl.find_opt tbl k); - length = (fun () -> Hashtbl.length tbl); - stats = my_stats; - level = 0; - } - in - - let emit delta = - (* Track input *) - my_stats.deltas_received <- my_stats.deltas_received + 1; - let entries = delta_to_entries delta in - my_stats.entries_received <- my_stats.entries_received + List.length entries; - let num_adds, num_removes = count_adds_removes entries in - my_stats.adds_received <- my_stats.adds_received + num_adds; - my_stats.removes_received <- my_stats.removes_received + num_removes; - - (* Apply to internal state immediately *) - (match delta with - | Set (k, v) -> Hashtbl.replace tbl k v - | Remove k -> Hashtbl.remove tbl k - | Batch entries -> - List.iter - (fun (k, v_opt) -> - match v_opt with - | Some v -> Hashtbl.replace tbl k v - | None -> Hashtbl.remove tbl k) - entries); - (* Accumulate for propagation *) - pending := delta :: !pending; - Registry.mark_dirty name; - (* If not in propagation, start one *) - if not (Scheduler.is_propagating ()) then Scheduler.propagate () - in - - (collection, emit) + let collection = + { + name; + subscribe = (fun h -> subscribers := h :: !subscribers); + iter = (fun f -> StableMap.iter f tbl); + get = (fun k -> StableMap.find_maybe tbl k); + length = (fun () -> StableMap.cardinal tbl); + destroy; + stats = my_stats; + level = 0; + node = my_info; + } + in + + let emit (input_wave : ('k, 'v Maybe.t) StableWave.t) = + let count = StableWave.count input_wave in + my_stats.deltas_received <- my_stats.deltas_received + 1; + my_stats.entries_received <- my_stats.entries_received + count; + (* Apply to internal state and accumulate into pending map *) + StableWave.iter_with input_wave apply_emit tables; + pending_count := !pending_count + 1; + Registry.mark_dirty_node my_info; + if not (Scheduler.is_propagating ()) then Scheduler.propagate () + in + + (collection, emit) +end (** {1 FlatMap} *) -let flatMap ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = - let my_level = src.level + 1 in - let merge_fn = - match merge with - | Some m -> m - | None -> fun _ v -> v - in - - (* Internal state *) - let provenance : ('k1, 'k2 list) Hashtbl.t = Hashtbl.create 64 in - let contributions : ('k2, ('k1, 'v2) Hashtbl.t) Hashtbl.t = - Hashtbl.create 256 - in - let target : ('k2, 'v2) Hashtbl.t = Hashtbl.create 256 in - let subscribers = ref [] in - let my_stats = create_stats () in - - (* Pending input deltas *) - let pending = ref [] in - - let recompute_target k2 = - match Hashtbl.find_opt contributions k2 with - | None -> - Hashtbl.remove target k2; - Some (k2, None) - | Some contribs when Hashtbl.length contribs = 0 -> - Hashtbl.remove contributions k2; - Hashtbl.remove target k2; - Some (k2, None) - | Some contribs -> - let values = Hashtbl.fold (fun _ v acc -> v :: acc) contribs [] in - let merged = - match values with - | [] -> assert false - | [v] -> v - | v :: rest -> List.fold_left merge_fn v rest - in - Hashtbl.replace target k2 merged; - Some (k2, Some merged) - in - - let remove_source k1 = - match Hashtbl.find_opt provenance k1 with - | None -> [] - | Some target_keys -> - Hashtbl.remove provenance k1; - List.iter - (fun k2 -> - match Hashtbl.find_opt contributions k2 with - | None -> () - | Some contribs -> Hashtbl.remove contribs k1) - target_keys; - target_keys - in - - let add_source k1 entries = - let target_keys = List.map fst entries in - Hashtbl.replace provenance k1 target_keys; - List.iter - (fun (k2, v2) -> - let contribs = - match Hashtbl.find_opt contributions k2 with - | Some c -> c - | None -> - let c = Hashtbl.create 4 in - Hashtbl.replace contributions k2 c; - c - in - Hashtbl.replace contribs k1 v2) - entries; - target_keys - in - - let process_entry (k1, v1_opt) = - let old_affected = remove_source k1 in - let new_affected = - match v1_opt with - | None -> [] - | Some v1 -> - let entries = f k1 v1 in - add_source k1 entries +module FlatMap = struct + let create ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = + let my_level = src.level + 1 in + let merge_fn = + match merge with + | Some m -> m + | None -> fun _ v -> v in - let all_affected = old_affected @ new_affected in - (* Deduplicate *) - let seen = Hashtbl.create (List.length all_affected) in - List.filter_map - (fun k2 -> - if Hashtbl.mem seen k2 then None - else ( - Hashtbl.replace seen k2 (); - recompute_target k2)) - all_affected - in - - let process () = - if !pending <> [] then ( - (* Track input deltas *) - my_stats.deltas_received <- - my_stats.deltas_received + List.length !pending; - let entries = - !pending |> List.concat_map delta_to_entries |> merge_entries - in - pending := []; + + let subscribers = ref [] in + let my_stats = create_stats () in + let state = ReactiveFlatMap.create ~f ~merge:merge_fn in + let pending_count = ref 0 in + + let process () = + let consumed = !pending_count in + pending_count := 0; + + my_stats.deltas_received <- my_stats.deltas_received + consumed; + + Registry.dec_inflight_node src.node consumed; + + let r = ReactiveFlatMap.process state in my_stats.entries_received <- - my_stats.entries_received + List.length entries; - let in_adds, in_removes = count_adds_removes entries in - my_stats.adds_received <- my_stats.adds_received + in_adds; - my_stats.removes_received <- my_stats.removes_received + in_removes; - - let output_entries = entries |> List.concat_map process_entry in - if output_entries <> [] then ( - let num_adds, num_removes = count_changes output_entries in + my_stats.entries_received + r.entries_received; + my_stats.adds_received <- my_stats.adds_received + r.adds_received; + my_stats.removes_received <- + my_stats.removes_received + r.removes_received; + + if r.entries_emitted > 0 then ( + let output_wave = ReactiveFlatMap.output_wave state in my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; - my_stats.entries_emitted <- - my_stats.entries_emitted + List.length output_entries; - my_stats.adds_emitted <- my_stats.adds_emitted + num_adds; - my_stats.removes_emitted <- my_stats.removes_emitted + num_removes; - let delta = Batch output_entries in - List.iter (fun h -> h delta) !subscribers)) - in - - let _info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats - in - Registry.add_edge ~from_name:src.name ~to_name:name ~label:"flatMap"; - - (* Subscribe to source: just accumulate *) - src.subscribe (fun delta -> - pending := delta :: !pending; - Registry.mark_dirty name); - - (* Initialize from existing data *) - src.iter (fun k v -> - let entries = f k v in - let _ = add_source k entries in - List.iter - (fun (k2, v2) -> - let contribs = - match Hashtbl.find_opt contributions k2 with - | Some c -> c - | None -> - let c = Hashtbl.create 4 in - Hashtbl.replace contributions k2 c; - c - in - Hashtbl.replace contribs k v2; - Hashtbl.replace target k2 v2) - entries); + my_stats.entries_emitted <- my_stats.entries_emitted + r.entries_emitted; + my_stats.adds_emitted <- my_stats.adds_emitted + r.adds_emitted; + my_stats.removes_emitted <- my_stats.removes_emitted + r.removes_emitted; + notify_subscribers output_wave !subscribers) + in - { - name; - subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> Hashtbl.iter f target); - get = (fun k -> Hashtbl.find_opt target k); - length = (fun () -> Hashtbl.length target); - stats = my_stats; - level = my_level; - } + let destroy () = ReactiveFlatMap.destroy state in + let my_info = + Registry.register_node ~name ~level:my_level ~process ~destroy + ~stats:my_stats + in + Registry.add_edge ~from_name:src.name ~to_name:name ~label:"flatMap"; + + (* Subscribe to source: push directly into pending map *) + src.subscribe (fun wave -> + Registry.inc_inflight_node src.node; + incr pending_count; + StableWave.iter_with wave ReactiveFlatMap.push state; + Registry.mark_dirty_node my_info); + + (* Initialize from existing data *) + src.iter (fun k v -> ReactiveFlatMap.init_entry state k v); + + { + name; + subscribe = (fun h -> subscribers := h :: !subscribers); + iter = (fun f -> ReactiveFlatMap.iter_target f state); + get = (fun k -> ReactiveFlatMap.find_target state k); + length = (fun () -> ReactiveFlatMap.target_length state); + destroy; + stats = my_stats; + level = my_level; + node = my_info; + } +end (** {1 Join} *) -let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () - : ('k3, 'v3) t = - let my_level = max left.level right.level + 1 in - let merge_fn = - match merge with - | Some m -> m - | None -> fun _ v -> v - in - - (* Internal state *) - let left_entries : ('k1, 'v1) Hashtbl.t = Hashtbl.create 64 in - let provenance : ('k1, 'k3 list) Hashtbl.t = Hashtbl.create 64 in - let contributions : ('k3, ('k1, 'v3) Hashtbl.t) Hashtbl.t = - Hashtbl.create 256 - in - let target : ('k3, 'v3) Hashtbl.t = Hashtbl.create 256 in - let left_to_right_key : ('k1, 'k2) Hashtbl.t = Hashtbl.create 64 in - let right_key_to_left_keys : ('k2, 'k1 list) Hashtbl.t = Hashtbl.create 64 in - let subscribers = ref [] in - let my_stats = create_stats () in - - (* Separate pending buffers for left and right *) - let left_pending = ref [] in - let right_pending = ref [] in - - let recompute_target k3 = - match Hashtbl.find_opt contributions k3 with - | None -> - Hashtbl.remove target k3; - Some (k3, None) - | Some contribs when Hashtbl.length contribs = 0 -> - Hashtbl.remove contributions k3; - Hashtbl.remove target k3; - Some (k3, None) - | Some contribs -> - let values = Hashtbl.fold (fun _ v acc -> v :: acc) contribs [] in - let merged = - match values with - | [] -> assert false - | [v] -> v - | v :: rest -> List.fold_left merge_fn v rest - in - Hashtbl.replace target k3 merged; - Some (k3, Some merged) - in - - let remove_left_contributions k1 = - match Hashtbl.find_opt provenance k1 with - | None -> [] - | Some target_keys -> - Hashtbl.remove provenance k1; - List.iter - (fun k3 -> - match Hashtbl.find_opt contributions k3 with - | None -> () - | Some contribs -> Hashtbl.remove contribs k1) - target_keys; - target_keys - in - - let add_left_contributions k1 entries = - let target_keys = List.map fst entries in - Hashtbl.replace provenance k1 target_keys; - List.iter - (fun (k3, v3) -> - let contribs = - match Hashtbl.find_opt contributions k3 with - | Some c -> c - | None -> - let c = Hashtbl.create 4 in - Hashtbl.replace contributions k3 c; - c - in - Hashtbl.replace contribs k1 v3) - entries; - target_keys - in - - let process_left_entry k1 v1 = - let old_affected = remove_left_contributions k1 in - (* Update right key tracking *) - (match Hashtbl.find_opt left_to_right_key k1 with - | Some old_k2 -> ( - Hashtbl.remove left_to_right_key k1; - match Hashtbl.find_opt right_key_to_left_keys old_k2 with - | Some keys -> - Hashtbl.replace right_key_to_left_keys old_k2 - (List.filter (fun k -> k <> k1) keys) - | None -> ()) - | None -> ()); - let k2 = key_of k1 v1 in - Hashtbl.replace left_to_right_key k1 k2; - let keys = - match Hashtbl.find_opt right_key_to_left_keys k2 with - | Some ks -> ks - | None -> [] - in - Hashtbl.replace right_key_to_left_keys k2 (k1 :: keys); - (* Compute output *) - let right_val = right.get k2 in - let new_entries = f k1 v1 right_val in - let new_affected = add_left_contributions k1 new_entries in - old_affected @ new_affected - in - - let remove_left_entry k1 = - Hashtbl.remove left_entries k1; - let affected = remove_left_contributions k1 in - (match Hashtbl.find_opt left_to_right_key k1 with - | Some k2 -> ( - Hashtbl.remove left_to_right_key k1; - match Hashtbl.find_opt right_key_to_left_keys k2 with - | Some keys -> - Hashtbl.replace right_key_to_left_keys k2 - (List.filter (fun k -> k <> k1) keys) - | None -> ()) - | None -> ()); - affected - in - - let process () = - (* Track input deltas *) - my_stats.deltas_received <- - my_stats.deltas_received + List.length !left_pending - + List.length !right_pending; - - (* Process both left and right pending *) - let left_entries_list = - !left_pending |> List.concat_map delta_to_entries |> merge_entries +module Join = struct + let create ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f + ?merge () : ('k3, 'v3) t = + let my_level = max left.level right.level + 1 in + let merge_fn = + match merge with + | Some m -> m + | None -> fun _ v -> v in - let right_entries_list = - !right_pending |> List.concat_map delta_to_entries |> merge_entries + + let subscribers = ref [] in + let my_stats = create_stats () in + let state = + ReactiveJoin.create ~key_of ~f ~merge:merge_fn ~right_get:right.get in - left_pending := []; - right_pending := []; - - my_stats.entries_received <- - my_stats.entries_received - + List.length left_entries_list - + List.length right_entries_list; - let left_adds, left_removes = count_adds_removes left_entries_list in - let right_adds, right_removes = count_adds_removes right_entries_list in - my_stats.adds_received <- my_stats.adds_received + left_adds + right_adds; - my_stats.removes_received <- - my_stats.removes_received + left_removes + right_removes; - - let all_affected = ref [] in - - (* Process left entries *) - List.iter - (fun (k1, v1_opt) -> - match v1_opt with - | Some v1 -> - Hashtbl.replace left_entries k1 v1; - let affected = process_left_entry k1 v1 in - all_affected := affected @ !all_affected - | None -> - let affected = remove_left_entry k1 in - all_affected := affected @ !all_affected) - left_entries_list; - - (* Process right entries: reprocess affected left entries *) - List.iter - (fun (k2, _) -> - match Hashtbl.find_opt right_key_to_left_keys k2 with - | None -> () - | Some left_keys -> - List.iter - (fun k1 -> - match Hashtbl.find_opt left_entries k1 with - | Some v1 -> - let affected = process_left_entry k1 v1 in - all_affected := affected @ !all_affected - | None -> ()) - left_keys) - right_entries_list; - - (* Deduplicate and compute outputs *) - let seen = Hashtbl.create (List.length !all_affected) in - let output_entries = - !all_affected - |> List.filter_map (fun k3 -> - if Hashtbl.mem seen k3 then None - else ( - Hashtbl.replace seen k3 (); - recompute_target k3)) + let left_pending_count = ref 0 in + let right_pending_count = ref 0 in + + let process () = + let consumed_left = !left_pending_count in + let consumed_right = !right_pending_count in + left_pending_count := 0; + right_pending_count := 0; + + my_stats.deltas_received <- + my_stats.deltas_received + consumed_left + consumed_right; + + Registry.dec_inflight_node left.node consumed_left; + Registry.dec_inflight_node right.node consumed_right; + + let r = ReactiveJoin.process state in + my_stats.entries_received <- + my_stats.entries_received + r.entries_received; + my_stats.adds_received <- my_stats.adds_received + r.adds_received; + my_stats.removes_received <- + my_stats.removes_received + r.removes_received; + + if r.entries_emitted > 0 then ( + let output_wave = ReactiveJoin.output_wave state in + my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; + my_stats.entries_emitted <- my_stats.entries_emitted + r.entries_emitted; + my_stats.adds_emitted <- my_stats.adds_emitted + r.adds_emitted; + my_stats.removes_emitted <- my_stats.removes_emitted + r.removes_emitted; + notify_subscribers output_wave !subscribers) in - if output_entries <> [] then ( - let num_adds, num_removes = count_changes output_entries in - my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; - my_stats.entries_emitted <- - my_stats.entries_emitted + List.length output_entries; - my_stats.adds_emitted <- my_stats.adds_emitted + num_adds; - my_stats.removes_emitted <- my_stats.removes_emitted + num_removes; - let delta = Batch output_entries in - List.iter (fun h -> h delta) !subscribers) - in - - let _info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats - in - Registry.add_edge ~from_name:left.name ~to_name:name ~label:"join"; - Registry.add_edge ~from_name:right.name ~to_name:name ~label:"join"; - Registry.add_combinator ~name:(name ^ "_join") ~shape:"join" - ~inputs:[left.name; right.name] ~output:name; - - (* Subscribe to sources: just accumulate *) - left.subscribe (fun delta -> - left_pending := delta :: !left_pending; - Registry.mark_dirty name); - - right.subscribe (fun delta -> - right_pending := delta :: !right_pending; - Registry.mark_dirty name); - - (* Initialize from existing data *) - left.iter (fun k1 v1 -> - Hashtbl.replace left_entries k1 v1; - let _ = process_left_entry k1 v1 in - ()); + let destroy () = ReactiveJoin.destroy state in + let my_info = + Registry.register_node ~name ~level:my_level ~process ~destroy + ~stats:my_stats + in + Registry.add_edge ~from_name:left.name ~to_name:name ~label:"join"; + Registry.add_edge ~from_name:right.name ~to_name:name ~label:"join"; + Registry.add_combinator ~name:(name ^ "_join") ~shape:"join" + ~inputs:[left.name; right.name] ~output:name; + + (* Subscribe to sources: push directly into pending maps *) + left.subscribe (fun wave -> + Registry.inc_inflight_node left.node; + incr left_pending_count; + StableWave.iter_with wave ReactiveJoin.push_left state; + Registry.mark_dirty_node my_info); + + right.subscribe (fun wave -> + Registry.inc_inflight_node right.node; + incr right_pending_count; + StableWave.iter_with wave ReactiveJoin.push_right state; + Registry.mark_dirty_node my_info); + + (* Initialize from existing data *) + left.iter (fun k1 v1 -> ReactiveJoin.init_entry state k1 v1); - { - name; - subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> Hashtbl.iter f target); - get = (fun k -> Hashtbl.find_opt target k); - length = (fun () -> Hashtbl.length target); - stats = my_stats; - level = my_level; - } + { + name; + subscribe = (fun h -> subscribers := h :: !subscribers); + iter = (fun f -> ReactiveJoin.iter_target f state); + get = (fun k -> ReactiveJoin.find_target state k); + length = (fun () -> ReactiveJoin.target_length state); + destroy; + stats = my_stats; + level = my_level; + node = my_info; + } +end (** {1 Union} *) -let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t - = - let my_level = max left.level right.level + 1 in - let merge_fn = - match merge with - | Some m -> m - | None -> fun _ v -> v - in - - (* Internal state *) - let left_values : ('k, 'v) Hashtbl.t = Hashtbl.create 64 in - let right_values : ('k, 'v) Hashtbl.t = Hashtbl.create 64 in - let target : ('k, 'v) Hashtbl.t = Hashtbl.create 128 in - let subscribers = ref [] in - let my_stats = create_stats () in - - (* Separate pending buffers *) - let left_pending = ref [] in - let right_pending = ref [] in - - let recompute_target k = - match (Hashtbl.find_opt left_values k, Hashtbl.find_opt right_values k) with - | None, None -> - Hashtbl.remove target k; - Some (k, None) - | Some v, None | None, Some v -> - Hashtbl.replace target k v; - Some (k, Some v) - | Some lv, Some rv -> - let merged = merge_fn lv rv in - Hashtbl.replace target k merged; - Some (k, Some merged) - in - - let process () = - (* Track input deltas *) - my_stats.deltas_received <- - my_stats.deltas_received + List.length !left_pending - + List.length !right_pending; - - let left_entries = - !left_pending |> List.concat_map delta_to_entries |> merge_entries +module Union = struct + let create ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : + ('k, 'v) t = + let my_level = max left.level right.level + 1 in + let merge_fn = + match merge with + | Some m -> m + | None -> fun _ v -> v in - let right_entries = - !right_pending |> List.concat_map delta_to_entries |> merge_entries - in - left_pending := []; - right_pending := []; - my_stats.entries_received <- - my_stats.entries_received + List.length left_entries - + List.length right_entries; - let left_adds, left_removes = count_adds_removes left_entries in - let right_adds, right_removes = count_adds_removes right_entries in - my_stats.adds_received <- my_stats.adds_received + left_adds + right_adds; - my_stats.removes_received <- - my_stats.removes_received + left_removes + right_removes; + let subscribers = ref [] in + let my_stats = create_stats () in + let state = ReactiveUnion.create ~merge:merge_fn in + let left_pending_count = ref 0 in + let right_pending_count = ref 0 in - let all_affected = ref [] in + let process () = + let consumed_left = !left_pending_count in + let consumed_right = !right_pending_count in + left_pending_count := 0; + right_pending_count := 0; - (* Apply left entries *) - List.iter - (fun (k, v_opt) -> - (match v_opt with - | Some v -> Hashtbl.replace left_values k v - | None -> Hashtbl.remove left_values k); - all_affected := k :: !all_affected) - left_entries; - - (* Apply right entries *) - List.iter - (fun (k, v_opt) -> - (match v_opt with - | Some v -> Hashtbl.replace right_values k v - | None -> Hashtbl.remove right_values k); - all_affected := k :: !all_affected) - right_entries; - - (* Deduplicate and compute outputs *) - let seen = Hashtbl.create (List.length !all_affected) in - let output_entries = - !all_affected - |> List.filter_map (fun k -> - if Hashtbl.mem seen k then None - else ( - Hashtbl.replace seen k (); - recompute_target k)) + my_stats.deltas_received <- + my_stats.deltas_received + consumed_left + consumed_right; + + Registry.dec_inflight_node left.node consumed_left; + Registry.dec_inflight_node right.node consumed_right; + + let r = ReactiveUnion.process state in + my_stats.entries_received <- + my_stats.entries_received + r.entries_received; + my_stats.adds_received <- my_stats.adds_received + r.adds_received; + my_stats.removes_received <- + my_stats.removes_received + r.removes_received; + + if r.entries_emitted > 0 then ( + let output_wave = ReactiveUnion.output_wave state in + my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; + my_stats.entries_emitted <- my_stats.entries_emitted + r.entries_emitted; + my_stats.adds_emitted <- my_stats.adds_emitted + r.adds_emitted; + my_stats.removes_emitted <- my_stats.removes_emitted + r.removes_emitted; + notify_subscribers output_wave !subscribers) in - if output_entries <> [] then ( - let num_adds, num_removes = count_changes output_entries in - my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; - my_stats.entries_emitted <- - my_stats.entries_emitted + List.length output_entries; - my_stats.adds_emitted <- my_stats.adds_emitted + num_adds; - my_stats.removes_emitted <- my_stats.removes_emitted + num_removes; - let delta = Batch output_entries in - List.iter (fun h -> h delta) !subscribers) - in - - let _info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats - in - Registry.add_edge ~from_name:left.name ~to_name:name ~label:"union"; - Registry.add_edge ~from_name:right.name ~to_name:name ~label:"union"; - Registry.add_combinator ~name:(name ^ "_union") ~shape:"union" - ~inputs:[left.name; right.name] ~output:name; - - (* Subscribe to sources: just accumulate *) - left.subscribe (fun delta -> - left_pending := delta :: !left_pending; - Registry.mark_dirty name); - - right.subscribe (fun delta -> - right_pending := delta :: !right_pending; - Registry.mark_dirty name); - - (* Initialize from existing data - process left then right *) - left.iter (fun k v -> - Hashtbl.replace left_values k v; - let merged = merge_fn v v in - (* self-merge for single value *) - Hashtbl.replace target k merged); - right.iter (fun k v -> - Hashtbl.replace right_values k v; - (* Right takes precedence, but merge if left exists *) - let merged = - match Hashtbl.find_opt left_values k with - | Some lv -> merge_fn lv v - | None -> v - in - Hashtbl.replace target k merged); + let destroy () = ReactiveUnion.destroy state in + let my_info = + Registry.register_node ~name ~level:my_level ~process ~destroy + ~stats:my_stats + in + Registry.add_edge ~from_name:left.name ~to_name:name ~label:"union"; + Registry.add_edge ~from_name:right.name ~to_name:name ~label:"union"; + Registry.add_combinator ~name:(name ^ "_union") ~shape:"union" + ~inputs:[left.name; right.name] ~output:name; + + (* Subscribe to sources: push directly into pending maps *) + left.subscribe (fun wave -> + Registry.inc_inflight_node left.node; + incr left_pending_count; + StableWave.iter_with wave ReactiveUnion.push_left state; + Registry.mark_dirty_node my_info); + + right.subscribe (fun wave -> + Registry.inc_inflight_node right.node; + incr right_pending_count; + StableWave.iter_with wave ReactiveUnion.push_right state; + Registry.mark_dirty_node my_info); + + (* Initialize from existing data - process left then right *) + left.iter (fun k v -> ReactiveUnion.init_left state k v); + right.iter (fun k v -> ReactiveUnion.init_right state k v); - { - name; - subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> Hashtbl.iter f target); - get = (fun k -> Hashtbl.find_opt target k); - length = (fun () -> Hashtbl.length target); - stats = my_stats; - level = my_level; - } + { + name; + subscribe = (fun h -> subscribers := h :: !subscribers); + iter = (fun f -> ReactiveUnion.iter_target f state); + get = (fun k -> ReactiveUnion.find_target state k); + length = (fun () -> ReactiveUnion.target_length state); + destroy; + stats = my_stats; + level = my_level; + node = my_info; + } +end (** {1 Fixpoint} *) -let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : - ('k, unit) t = - let my_level = max init.level edges.level + 1 in - - (* Internal state *) - let state = ReactiveFixpoint.create () in - let subscribers = ref [] in - let my_stats = create_stats () in - - (* Separate pending buffers *) - let init_pending = ref [] in - let edges_pending = ref [] in - - let emit_output output_entries = - if output_entries <> [] then ( - let num_adds, num_removes = count_changes output_entries in - my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; - my_stats.entries_emitted <- - my_stats.entries_emitted + List.length output_entries; - my_stats.adds_emitted <- my_stats.adds_emitted + num_adds; - my_stats.removes_emitted <- my_stats.removes_emitted + num_removes; - let delta = Batch output_entries in - List.iter (fun h -> h delta) !subscribers) - in - - let process () = - (* Track input deltas *) - my_stats.deltas_received <- - my_stats.deltas_received + List.length !init_pending - + List.length !edges_pending; - - let init_entries = - !init_pending |> List.concat_map delta_to_entries |> merge_entries +module Fixpoint = struct + let stable_wave_map_replace pending k v = StableMap.replace pending k v + + let stable_wave_push wave k v = StableWave.push wave k v + + let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k StableList.t) t) () + : ('k, unit) t = + let my_level = max init.level edges.level + 1 in + let int_env_or name default = + match Sys.getenv_opt name with + | None -> default + | Some s -> ( + match int_of_string_opt s with + | Some n when n > 0 -> n + | _ -> default) in - let edges_entries = - !edges_pending |> List.concat_map delta_to_entries |> merge_entries + + (* Internal state *) + let max_nodes = int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_NODES" 100_000 in + let max_edges = + int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_EDGES" 1_000_000 in - init_pending := []; - edges_pending := []; - - my_stats.entries_received <- - my_stats.entries_received + List.length init_entries - + List.length edges_entries; - let init_adds, init_removes = count_adds_removes init_entries in - let edges_adds, edges_removes = count_adds_removes edges_entries in - my_stats.adds_received <- my_stats.adds_received + init_adds + edges_adds; - my_stats.removes_received <- - my_stats.removes_received + init_removes + edges_removes; - - let output_entries = - ReactiveFixpoint.apply state ~init_entries ~edge_entries:edges_entries + let max_root_wave_entries = + int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_ROOT_WAVE_ENTRIES" 4_096 in - emit_output output_entries - in + let max_edge_wave_entries = + int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_EDGE_WAVE_ENTRIES" 16_384 + in + let state = ReactiveFixpoint.create ~max_nodes ~max_edges in + let root_wave = StableWave.create ~max_entries:max_root_wave_entries () in + let edge_wave = StableWave.create ~max_entries:max_edge_wave_entries () in + let subscribers = ref [] in + let my_stats = create_stats () in + let root_pending : ('k, unit Maybe.t) StableMap.t = StableMap.create () in + let edge_pending : ('k, 'k StableList.t Maybe.t) StableMap.t = + StableMap.create () + in + let init_pending_count = ref 0 in + let edges_pending_count = ref 0 in - let _info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats - in - Registry.add_edge ~from_name:init.name ~to_name:name ~label:"roots"; - Registry.add_edge ~from_name:edges.name ~to_name:name ~label:"edges"; - Registry.add_combinator ~name:(name ^ "_fp") ~shape:"fixpoint" - ~inputs:[init.name; edges.name] ~output:name; + let process () = + let consumed_init = !init_pending_count in + let consumed_edges = !edges_pending_count in + init_pending_count := 0; + edges_pending_count := 0; - (* Subscribe to sources: just accumulate *) - init.subscribe (fun delta -> - init_pending := delta :: !init_pending; - Registry.mark_dirty name); + my_stats.deltas_received <- + my_stats.deltas_received + consumed_init + consumed_edges; + Registry.dec_inflight_node init.node consumed_init; + Registry.dec_inflight_node edges.node consumed_edges; + + (* Dump pending maps into waves *) + StableWave.clear root_wave; + StableWave.clear edge_wave; + let root_entries = StableMap.cardinal root_pending in + let edge_entries = StableMap.cardinal edge_pending in + StableMap.iter_with stable_wave_push root_wave root_pending; + StableMap.iter_with stable_wave_push edge_wave edge_pending; + StableMap.clear root_pending; + StableMap.clear edge_pending; - edges.subscribe (fun delta -> - edges_pending := delta :: !edges_pending; - Registry.mark_dirty name); + my_stats.entries_received <- + my_stats.entries_received + root_entries + edge_entries; + my_stats.adds_received <- + my_stats.adds_received + root_entries + edge_entries; + + ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave; + let out_wave = ReactiveFixpoint.output_wave state in + let out_count = StableWave.count out_wave in + if out_count > 0 then ( + notify_subscribers out_wave !subscribers; + my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; + my_stats.entries_emitted <- my_stats.entries_emitted + out_count) + in - (* Initialize from existing data *) - ReactiveFixpoint.initialize state ~roots_iter:init.iter ~edges_iter:edges.iter; + let destroy () = + StableMap.destroy root_pending; + StableMap.destroy edge_pending; + StableWave.destroy root_wave; + StableWave.destroy edge_wave; + ReactiveFixpoint.destroy state + in + let my_info = + Registry.register_node ~name ~level:my_level ~process ~destroy + ~stats:my_stats + in + Registry.add_edge ~from_name:init.name ~to_name:name ~label:"roots"; + Registry.add_edge ~from_name:edges.name ~to_name:name ~label:"edges"; + Registry.add_combinator ~name:(name ^ "_fp") ~shape:"fixpoint" + ~inputs:[init.name; edges.name] ~output:name; + + (* Subscribe to sources: push directly into pending maps *) + init.subscribe (fun wave -> + Registry.inc_inflight_node init.node; + init_pending_count := !init_pending_count + 1; + StableWave.iter_with wave stable_wave_map_replace root_pending; + Registry.mark_dirty_node my_info); + + edges.subscribe (fun wave -> + Registry.inc_inflight_node edges.node; + edges_pending_count := !edges_pending_count + 1; + StableWave.iter_with wave stable_wave_map_replace edge_pending; + Registry.mark_dirty_node my_info); + + (* Initialize from existing data *) + let init_roots_wave = + StableWave.create ~max_entries:(max 1 (init.length ())) () + in + let init_edges_wave : ('k, 'k StableList.t) StableWave.t = + StableWave.create ~max_entries:(max 1 (edges.length ())) () + in + StableWave.clear init_roots_wave; + StableWave.clear init_edges_wave; + init.iter (fun k _unit -> StableWave.push init_roots_wave k Stable.unit); + edges.iter (fun k succs -> StableWave.push init_edges_wave k succs); + ReactiveFixpoint.initialize state ~roots:init_roots_wave + ~edges:init_edges_wave; + StableWave.destroy init_roots_wave; + StableWave.destroy init_edges_wave; - { - name; - subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> ReactiveFixpoint.iter_current state f); - get = (fun k -> ReactiveFixpoint.get_current state k); - length = (fun () -> ReactiveFixpoint.current_length state); - stats = my_stats; - level = my_level; - } + { + name; + subscribe = (fun h -> subscribers := h :: !subscribers); + iter = (fun f -> ReactiveFixpoint.iter_current state f); + get = (fun k -> ReactiveFixpoint.get_current state k); + length = (fun () -> ReactiveFixpoint.current_length state); + destroy; + stats = my_stats; + level = my_level; + node = my_info; + } +end (** {1 Utilities} *) let to_mermaid () = Registry.to_mermaid () let print_stats () = Registry.print_stats () let set_debug = set_debug +let destroy_graph () = Registry.destroy_graph () let reset () = Registry.clear () let reset_stats () = Registry.reset_stats () diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index cadaecc969..b91c5ad1f9 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -7,29 +7,16 @@ This eliminates glitches from multi-level dependencies by construction. *) -(** {1 Deltas} *) +(** {1 Waves} *) -type ('k, 'v) delta = - | Set of 'k * 'v - | Remove of 'k - | Batch of ('k * 'v option) list - (** Batch of updates: (key, Some value) = set, (key, None) = remove *) - -val set : 'k -> 'v -> 'k * 'v option -(** Create a batch entry that sets a key *) - -val remove : 'k -> 'k * 'v option -(** Create a batch entry that removes a key *) - -val delta_to_entries : ('k, 'v) delta -> ('k * 'v option) list -(** Convert delta to batch entries *) +type ('k, 'v) wave = ('k, 'v Maybe.t) StableWave.t +(** Mutable wave buffer carrying batch entries *) (** {1 Statistics} *) type stats = { (* Input tracking *) - mutable deltas_received: int; - (** Number of delta messages (Set/Remove/Batch) *) + mutable deltas_received: int; (** Number of delta messages (Batch) *) mutable entries_received: int; (** Total entries after expanding batches *) mutable adds_received: int; (** Set operations received from upstream *) mutable removes_received: int; @@ -56,6 +43,9 @@ module Registry : sig val clear : unit -> unit (** Clear all registered nodes *) + val destroy_graph : unit -> unit + (** Destroy all registered nodes, then clear the registry. *) + val to_mermaid : unit -> string (** Generate a Mermaid diagram of the pipeline *) @@ -84,75 +74,96 @@ end type ('k, 'v) t = { name: string; - subscribe: (('k, 'v) delta -> unit) -> unit; - iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v option; + subscribe: (('k, 'v) wave -> unit) -> unit; + iter: ('k Stable.t -> 'v Stable.t -> unit) -> unit; + get: 'k Stable.t -> 'v Stable.t Maybe.t; length: unit -> int; + destroy: unit -> unit; stats: stats; level: int; + node: Registry.node_info; } (** A named reactive collection at a specific topological level *) -val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit -val get : ('k, 'v) t -> 'k -> 'v option +val iter : ('k Stable.t -> 'v Stable.t -> unit) -> ('k, 'v) t -> unit +val get : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t Maybe.t val length : ('k, 'v) t -> int +val destroy : ('k, 'v) t -> unit val stats : ('k, 'v) t -> stats val level : ('k, 'v) t -> int val name : ('k, 'v) t -> string (** {1 Source Collection} *) -val source : name:string -> unit -> ('k, 'v) t * (('k, 'v) delta -> unit) -(** Create a named source collection. - Returns the collection and an emit function. - Emitting triggers propagation through the pipeline. *) +module Source : sig + val create : + name:string -> unit -> ('k, 'v) t * (('k, 'v Maybe.t) StableWave.t -> unit) + (** Create a named source collection. + Returns the collection and an emit function that takes a wave. + Each wave entry is a key with [Maybe.some v] for set + or [Maybe.none] for remove. + Emitting triggers propagation through the pipeline. *) +end (** {1 Combinators} *) -val flatMap : - name:string -> - ('k1, 'v1) t -> - f:('k1 -> 'v1 -> ('k2 * 'v2) list) -> - ?merge:('v2 -> 'v2 -> 'v2) -> - unit -> - ('k2, 'v2) t -(** Transform each entry into zero or more output entries. - Optional merge function combines values for the same output key. *) - -val join : - name:string -> - ('k1, 'v1) t -> - ('k2, 'v2) t -> - key_of:('k1 -> 'v1 -> 'k2) -> - f:('k1 -> 'v1 -> 'v2 option -> ('k3 * 'v3) list) -> - ?merge:('v3 -> 'v3 -> 'v3) -> - unit -> - ('k3, 'v3) t -(** Join left collection with right collection. - For each left entry, looks up the key in right. - Separate left/right pending buffers ensure glitch-freedom. *) - -val union : - name:string -> - ('k, 'v) t -> - ('k, 'v) t -> - ?merge:('v -> 'v -> 'v) -> - unit -> - ('k, 'v) t -(** Combine two collections. - Optional merge function combines values for the same key. - Separate left/right pending buffers ensure glitch-freedom. *) - -val fixpoint : - name:string -> - init:('k, unit) t -> - edges:('k, 'k list) t -> - unit -> - ('k, unit) t -(** Compute transitive closure. - init: initial roots - edges: k -> successors - Returns: all reachable keys from roots *) +module FlatMap : sig + val create : + name:string -> + ('k1, 'v1) t -> + f:('k1 Stable.t -> 'v1 Stable.t -> ('k2, 'v2) StableWave.t -> unit) -> + ?merge:('v2 Stable.t -> 'v2 Stable.t -> 'v2 Stable.t) -> + unit -> + ('k2, 'v2) t + (** Transform each entry into zero or more output entries. + Optional merge function combines values for the same output key. *) +end + +module Join : sig + val create : + name:string -> + ('k1, 'v1) t -> + ('k2, 'v2) t -> + key_of:('k1 Stable.t -> 'v1 Stable.t -> 'k2 Stable.t) -> + f: + ('k1 Stable.t -> + 'v1 Stable.t -> + 'v2 Stable.t Maybe.t -> + ('k3, 'v3) StableWave.t -> + unit) -> + ?merge:('v3 Stable.t -> 'v3 Stable.t -> 'v3 Stable.t) -> + unit -> + ('k3, 'v3) t + (** Join left collection with right collection. + For each left entry, looks up the key in right. + Separate left/right pending buffers ensure glitch-freedom. *) +end + +module Union : sig + val create : + name:string -> + ('k, 'v) t -> + ('k, 'v) t -> + ?merge:('v Stable.t -> 'v Stable.t -> 'v Stable.t) -> + unit -> + ('k, 'v) t + (** Combine two collections. + Optional merge function combines stable-marked values for the same key. + Separate left/right pending buffers ensure glitch-freedom. *) +end + +module Fixpoint : sig + val create : + name:string -> + init:('k, unit) t -> + edges:('k, 'k StableList.t) t -> + unit -> + ('k, unit) t + (** Compute transitive closure. + init: initial roots + edges: k -> successors + Returns: all reachable keys from roots *) +end (** {1 Utilities} *) @@ -168,5 +179,8 @@ val set_debug : bool -> unit val reset : unit -> unit (** Clear all registered nodes (for tests) *) +val destroy_graph : unit -> unit +(** Destroy all registered nodes, then clear the registry. *) + val reset_stats : unit -> unit (** Reset all node statistics to zero (keeps nodes intact) *) diff --git a/analysis/reactive/src/ReactiveAllocTrace.ml b/analysis/reactive/src/ReactiveAllocTrace.ml new file mode 100644 index 0000000000..9ee266671b --- /dev/null +++ b/analysis/reactive/src/ReactiveAllocTrace.ml @@ -0,0 +1,80 @@ +type trace_level = Off | Alloc_only | Alloc_and_ops + +let level = + match Sys.getenv_opt "RESCRIPT_REACTIVE_ALLOC_TRACE" with + | Some "2" -> Alloc_and_ops + | Some ("1" | "true" | "TRUE" | "yes" | "YES") -> Alloc_only + | _ -> Off + +let enabled = level <> Off +let ops_enabled = level = Alloc_and_ops + +let file_path = + match Sys.getenv_opt "RESCRIPT_REACTIVE_ALLOC_TRACE_FILE" with + | Some p when String.length p > 0 -> p + | _ -> "/tmp/rescript-reactive-alloc-events.log" + +let fd : Unix.file_descr option ref = ref None + +type alloc_event_kind = + | Map_create + | Map_vals_init + | Table_resize + | Set_create + | Set_resize + | Pool_set_resize + | Pool_set_miss_create + | Pool_map_resize + | Pool_map_miss_create + | Unknown_alloc + +type op_event_kind = + | Pool_set_drain_key + | Pool_set_remove_recycle_if_empty + | Pool_map_drain_outer + | Pool_map_remove_recycle_if_empty + | Unknown_op + +let get_fd () = + match !fd with + | Some f -> f + | None -> + let f = + Unix.openfile file_path + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_CLOEXEC] + 0o644 + in + fd := Some f; + f + +let emit_line line = + if enabled then + try + let f = get_fd () in + ignore (Unix.single_write_substring f line 0 (String.length line)) + with _ -> () + +let emit_alloc_kind kind = + if enabled then + match kind with + | Map_create -> emit_line "[ALLOC_EVT] map_create\n" + | Map_vals_init -> emit_line "[ALLOC_EVT] map_vals_init\n" + | Table_resize -> emit_line "[ALLOC_EVT] table_resize\n" + | Set_create -> emit_line "[ALLOC_EVT] set_create\n" + | Set_resize -> emit_line "[ALLOC_EVT] set_resize\n" + | Pool_set_resize -> emit_line "[ALLOC_EVT] pool_set_resize\n" + | Pool_set_miss_create -> emit_line "[ALLOC_EVT] pool_set_miss_create\n" + | Pool_map_resize -> emit_line "[ALLOC_EVT] pool_map_resize\n" + | Pool_map_miss_create -> emit_line "[ALLOC_EVT] pool_map_miss_create\n" + | Unknown_alloc -> emit_line "[ALLOC_EVT] unknown_alloc\n" + +let emit_op_kind kind = + if ops_enabled then + match kind with + | Pool_set_drain_key -> emit_line "[ALLOC_EVT] pool_set_drain_key\n" + | Pool_set_remove_recycle_if_empty -> + emit_line "[ALLOC_EVT] pool_set_remove_recycle_if_empty\n" + | Pool_map_drain_outer -> emit_line "[ALLOC_EVT] pool_map_drain_outer\n" + | Pool_map_remove_recycle_if_empty -> + emit_line "[ALLOC_EVT] pool_map_remove_recycle_if_empty\n" + | Unknown_op -> emit_line "[ALLOC_EVT] unknown_op\n" diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index bcae68a0b7..4dbd4bb7a2 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -23,21 +23,28 @@ type ('raw, 'v) internal = { type ('raw, 'v) t = { internal: ('raw, 'v) internal; collection: (string, 'v) Reactive.t; - emit: (string, 'v) Reactive.delta -> unit; + emit: (string, 'v Maybe.t) StableWave.t -> unit; + scratch_wave: (string, 'v Maybe.t) StableWave.t; } (** A file collection is just a Reactive.t with some extra operations *) (** Create a new reactive file collection *) let create ~read_file ~process : ('raw, 'v) t = let internal = {cache = Hashtbl.create 256; read_file; process} in - let collection, emit = Reactive.source ~name:"file_collection" () in - {internal; collection; emit} + let collection, emit = Reactive.Source.create ~name:"file_collection" () in + let scratch_wave = StableWave.create () in + {internal; collection; emit; scratch_wave} (** Get the collection interface for composition *) let to_collection t : (string, 'v) Reactive.t = t.collection -(** Emit a delta *) -let emit t delta = t.emit delta +(** Emit a single set entry *) +let emit_set t path value = + StableWave.clear t.scratch_wave; + StableWave.push t.scratch_wave + (Stable.unsafe_of_value path) + (Stable.unsafe_of_value (Maybe.some value)); + t.emit t.scratch_wave (** Process a file if changed. Emits delta to subscribers. *) let process_if_changed t path = @@ -49,51 +56,68 @@ let process_if_changed t path = let raw = t.internal.read_file path in let value = t.internal.process path raw in Hashtbl.replace t.internal.cache path (new_id, value); - emit t (Reactive.Set (path, value)); + emit_set t path value; true (* changed *) (** Process multiple files (emits individual deltas) *) let process_files t paths = List.iter (fun path -> ignore (process_if_changed t path)) paths -(** Process a file without emitting. Returns batch entry if changed. *) -let process_file_silent t path = - let new_id = get_file_id path in - match Hashtbl.find_opt t.internal.cache path with - | Some (old_id, _) when not (file_changed ~old_id ~new_id) -> - None (* unchanged *) - | _ -> - let raw = t.internal.read_file path in - let value = t.internal.process path raw in - Hashtbl.replace t.internal.cache path (new_id, value); - Some (Reactive.set path value) - (** Process multiple files and emit as a single batch. More efficient than process_files when processing many files at once. *) let process_files_batch t paths = - let entries = - paths |> List.filter_map (fun path -> process_file_silent t path) - in - if entries <> [] then emit t (Reactive.Batch entries); - List.length entries + StableWave.clear t.scratch_wave; + let count = ref 0 in + (* Accumulate changes in an OCaml list to keep values reachable from GC roots. + We must not store minor-heap values directly into C-allocated scratch_wave + because the GC cannot update pointers in C memory when it moves objects. *) + let changes = ref [] in + List.iter + (fun path -> + let new_id = get_file_id path in + match Hashtbl.find_opt t.internal.cache path with + | Some (old_id, _) when not (file_changed ~old_id ~new_id) -> () + | _ -> + let raw = t.internal.read_file path in + let value = t.internal.process path raw in + Hashtbl.replace t.internal.cache path (new_id, value); + changes := (path, value) :: !changes; + incr count) + paths; + if !count > 0 then ( + (* Promote all values to the major heap. After this, addresses are stable + (minor GC never moves major-heap objects, and we don't compact). *) + Gc.full_major (); + List.iter + (fun (path, value) -> + StableWave.push t.scratch_wave (Stable.of_value path) + (Stable.of_value (Maybe.some value))) + !changes; + t.emit t.scratch_wave); + !count (** Remove a file *) let remove t path = Hashtbl.remove t.internal.cache path; - emit t (Reactive.Remove path) + StableWave.clear t.scratch_wave; + StableWave.push t.scratch_wave (Stable.unsafe_of_value path) Maybe.none_stable; + t.emit t.scratch_wave (** Remove multiple files as a batch *) let remove_batch t paths = - let entries = - paths - |> List.filter_map (fun path -> - if Hashtbl.mem t.internal.cache path then ( - Hashtbl.remove t.internal.cache path; - Some (path, None)) - else None) - in - if entries <> [] then emit t (Reactive.Batch entries); - List.length entries + StableWave.clear t.scratch_wave; + let count = ref 0 in + List.iter + (fun path -> + if Hashtbl.mem t.internal.cache path then ( + Hashtbl.remove t.internal.cache path; + StableWave.push t.scratch_wave + (Stable.unsafe_of_value path) + Maybe.none_stable; + incr count)) + paths; + if !count > 0 then t.emit t.scratch_wave; + !count (** Clear all cached data *) let clear t = Hashtbl.clear t.internal.cache @@ -108,4 +132,6 @@ let get t path = let mem t path = Hashtbl.mem t.internal.cache path let length t = Reactive.length t.collection -let iter f t = Reactive.iter f t.collection +let iter f t = + t.collection.iter (fun k v -> + f (Stable.to_linear_value k) (Stable.to_linear_value v)) diff --git a/analysis/reactive/src/ReactiveFileCollection.mli b/analysis/reactive/src/ReactiveFileCollection.mli index e50c661828..f4d1b301e6 100644 --- a/analysis/reactive/src/ReactiveFileCollection.mli +++ b/analysis/reactive/src/ReactiveFileCollection.mli @@ -11,7 +11,7 @@ ~process:(fun path cmt -> extract_data path cmt) (* Compose with flatMap *) - let decls = Reactive.flatMap ~name:"decls" (ReactiveFileCollection.to_collection files) + let decls = Reactive.FlatMap.create ~name:"decls" (ReactiveFileCollection.to_collection files) ~f:(fun _path data -> data.decls) () @@ -35,7 +35,8 @@ val create : (** {1 Composition} *) val to_collection : ('raw, 'v) t -> (string, 'v) Reactive.t -(** Get the reactive collection interface for use with [Reactive.flatMap]. *) +(** Get the reactive collection interface for use with + [Reactive.FlatMap.create]. *) (** {1 Processing} *) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index c3f153e127..13224dd54d 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -1,64 +1,138 @@ -type 'k t = { - current: ('k, unit) Hashtbl.t; - edge_map: ('k, 'k list) Hashtbl.t; - pred_map: ('k, ('k, unit) Hashtbl.t) Hashtbl.t; - roots: ('k, unit) Hashtbl.t; +(* Note on set representations: + [pred_map] is represented by [StableMapSet] because its semantics are + exactly map-of-set with churn-safe remove+recycle behavior. *) + +type 'k metrics_state = { + mutable delete_queue_pops: int; + mutable delete_edges_scanned: int; + mutable rederive_queue_pops: int; + mutable rederived_nodes: int; + mutable rederive_edges_scanned: int; + mutable expansion_queue_pops: int; + mutable expansion_edges_scanned: int; + scratch_reachable: 'k StableSet.t; } +(** Per-call metrics scratch state. Allocated once per fixpoint instance, + mutable fields are reset and incremented in-place — zero allocation. *) -type 'k edge_change = { - src: 'k; - old_succs: 'k list; - new_succs: 'k list; - removed_targets: 'k list; - has_new_edge: bool; +type 'k t = { + current: 'k StableSet.t; + edge_map: ('k, 'k StableList.t) StableMap.t; + pred_map: ('k, 'k) StableMapSet.t; + roots: 'k StableSet.t; + output_wave: ('k, unit Maybe.t) StableWave.t; + (* Scratch tables — allocated once, cleared per apply_list call *) + deleted_nodes: 'k StableSet.t; + rederive_pending: 'k StableSet.t; + expansion_seen: 'k StableSet.t; + old_successors_for_changed: ('k, 'k StableList.t) StableMap.t; + new_successors_for_changed: ('k, 'k StableList.t) StableMap.t; + (* Scratch sets for analyze_edge_change / apply_edge_update *) + scratch_set_a: 'k StableSet.t; + scratch_set_b: 'k StableSet.t; + edge_has_new: 'k StableSet.t; + (* Scratch queues *) + delete_queue: 'k StableQueue.t; + rederive_queue: 'k StableQueue.t; + expansion_queue: 'k StableQueue.t; + added_roots_queue: 'k StableQueue.t; + edge_change_queue: 'k StableQueue.t; + metrics: 'k metrics_state; } -let analyze_edge_change ~old_succs ~new_succs = - match (old_succs, new_succs) with - | [], [] -> ([], false) - | [], _ -> ([], true) - | _, [] -> (old_succs, false) - | _, _ -> - let new_set = Hashtbl.create (List.length new_succs) in - List.iter (fun k -> Hashtbl.replace new_set k ()) new_succs; - let old_set = Hashtbl.create (List.length old_succs) in - List.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; - let removed_targets = - List.filter (fun target -> not (Hashtbl.mem new_set target)) old_succs - in - let has_new_edge = - List.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs - in - (removed_targets, has_new_edge) - -let compute_reachable_from_roots_with_work t = - let new_current = Hashtbl.create (Hashtbl.length t.current) in - let frontier = Queue.create () in - let nodes_visited = ref 0 in - let edges_scanned = ref 0 in - - Hashtbl.iter - (fun k () -> - Hashtbl.replace new_current k (); - incr nodes_visited; - Queue.add k frontier) - t.roots; - - while not (Queue.is_empty frontier) do - let k = Queue.pop frontier in - match Hashtbl.find_opt t.edge_map k with - | None -> () - | Some successors -> - edges_scanned := !edges_scanned + List.length successors; - List.iter - (fun succ -> - if not (Hashtbl.mem new_current succ) then ( - Hashtbl.replace new_current succ (); - incr nodes_visited; - Queue.add succ frontier)) - successors +let set_add_k set k = StableSet.add set k +let not_in_set set k = not (StableSet.mem set k) + +let analyze_edge_change_has_new scratch ~old_succs ~new_succs = + if StableList.is_empty old_succs then not (StableList.is_empty new_succs) + else if StableList.is_empty new_succs then false + else ( + StableSet.clear scratch; + StableList.iter_with set_add_k scratch old_succs; + StableList.exists_with not_in_set scratch new_succs) + +let[@inline] enqueue q k = StableQueue.push q k + +(* Helpers for StableList values stored in StableMap/StableWave. + The map stores 'v Stable.t, so find returns StableList.t Stable.t + and replace expects StableList.t Stable.t. *) +let[@inline] succs_of_stable (s : 'a StableList.t Stable.t) : 'a StableList.t = + Stable.to_linear_value s + +let[@inline] find_succs map k = + let r = StableMap.find_maybe map k in + if Maybe.is_some r then succs_of_stable (Maybe.unsafe_get r) + else StableList.empty () + +let[@inline] succs_of_maybe mv = + if Maybe.is_some mv then succs_of_stable (Maybe.unsafe_get mv) + else StableList.empty () + +(* Full-reachability BFS into [visited]. Returns (node_work, edge_work). + [visited] is cleared before use; zero allocation when [visited] is + pre-allocated (e.g. Metrics scratch map). *) +let bfs_seed (visited, frontier) k = + StableSet.add visited k; + StableQueue.push frontier k + +let bfs_visit_succ (visited, frontier) succ = + if not (StableSet.mem visited succ) then ( + StableSet.add visited succ; + StableQueue.push frontier succ) + +let compute_reachable ~visited t = + StableSet.clear visited; + let frontier = t.delete_queue in + StableQueue.clear frontier; + let node_work = ref 0 in + let edge_work = ref 0 in + let vf = (visited, frontier) in + StableSet.iter_with (fun vf k -> bfs_seed vf k) vf t.roots; + while not (StableQueue.is_empty frontier) do + let k = StableQueue.pop frontier in + incr node_work; + let r = StableMap.find_maybe t.edge_map k in + if Maybe.is_some r then ( + let succs = succs_of_stable (Maybe.unsafe_get r) in + edge_work := !edge_work + StableList.length succs; + StableList.iter_with bfs_visit_succ vf succs) done; - (new_current, !nodes_visited, !edges_scanned) + (!node_work, !edge_work) + +(* Functions needed by Invariants — defined early to avoid closures *) +let has_live_pred_key t pred = StableSet.mem t.current pred + +let has_live_predecessor t k = + StableMapSet.exists_inner_with t.pred_map k t has_live_pred_key + +let is_supported t k = StableSet.mem t.roots k || has_live_predecessor t k + +let old_successors t k = + let r = StableMap.find_maybe t.old_successors_for_changed k in + if Maybe.is_some r then succs_of_stable (Maybe.unsafe_get r) + else find_succs t.edge_map k + +(* BFS variant for invariants — takes t directly, zero alloc *) +let bfs_seed_scratch t k = + StableSet.add t.metrics.scratch_reachable k; + StableQueue.push t.delete_queue k + +let bfs_visit_scratch t succ = + if not (StableSet.mem t.metrics.scratch_reachable succ) then ( + StableSet.add t.metrics.scratch_reachable succ; + StableQueue.push t.delete_queue succ) + +let fill_reachable_scratch t = + StableSet.clear t.metrics.scratch_reachable; + StableQueue.clear t.delete_queue; + StableSet.iter_with bfs_seed_scratch t t.roots; + while not (StableQueue.is_empty t.delete_queue) do + let k = StableQueue.pop t.delete_queue in + let r = StableMap.find_maybe t.edge_map k in + if Maybe.is_some r then + StableList.iter_with bfs_visit_scratch t + (succs_of_stable (Maybe.unsafe_get r)) + done module Metrics = struct let enabled = @@ -103,6 +177,16 @@ module Metrics = struct max_rederived_nodes = 0; } + let reset_per_call (m : _ metrics_state) = + if enabled then ( + m.delete_queue_pops <- 0; + m.delete_edges_scanned <- 0; + m.rederive_queue_pops <- 0; + m.rederived_nodes <- 0; + m.rederive_edges_scanned <- 0; + m.expansion_queue_pops <- 0; + m.expansion_edges_scanned <- 0) + let update ~init_entries ~edge_entries ~output_entries ~deleted_nodes ~rederived_nodes ~incr_node_work ~incr_edge_work ~full_node_work ~full_edge_work = @@ -189,448 +273,474 @@ module Invariants = struct let assert_ condition message = if enabled && not condition then failwith message - let copy_set tbl = - let out = Hashtbl.create (Hashtbl.length tbl) in - Hashtbl.iter (fun k () -> Hashtbl.replace out k ()) tbl; - out - - let set_equal a b = - Hashtbl.length a = Hashtbl.length b - && - let ok = ref true in - Hashtbl.iter (fun k () -> if not (Hashtbl.mem b k) then ok := false) a; - !ok - - let assert_edge_changes_consistent edge_changes = - (* Invariant: for each change, [removed_targets = old_succs \\ new_succs] - and [has_new_edge <=> (new_succs \\ old_succs <> empty)]. *) + (* Callbacks for assert_edge_has_new_consistent *) + let check_edge_has_new_entry old_succs_set t src old_succs_s = + let old_succs = succs_of_stable old_succs_s in + let new_succs = find_succs t.new_successors_for_changed src in + let recomputed = + analyze_edge_change_has_new old_succs_set ~old_succs ~new_succs + in + assert_ + (recomputed = StableSet.mem t.edge_has_new src) + "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new" + + let assert_edge_has_new_consistent old_succs_set t = + if enabled && Maybe.is_some old_succs_set then + StableMap.iter_with2 check_edge_has_new_entry + (Maybe.unsafe_get old_succs_set) + t t.old_successors_for_changed + + (* Callbacks for assert_deleted_nodes_closed *) + let check_succ_in_deleted t succ = + if StableSet.mem t.current succ then + assert_ + (StableSet.mem t.deleted_nodes succ) + "ReactiveFixpoint.apply invariant failed: deleted closure broken" + + let check_deleted_node_closed t k = + assert_ + (StableSet.mem t.current k) + "ReactiveFixpoint.apply invariant failed: deleted node not in current"; + StableList.iter_with check_succ_in_deleted t (old_successors t k) + + let assert_deleted_nodes_closed t = if enabled then - List.iter - (fun ({old_succs; new_succs; removed_targets; has_new_edge; _} : - _ edge_change) -> - let expected_removed, expected_has_new = - analyze_edge_change ~old_succs ~new_succs - in - assert_ - (removed_targets = expected_removed - && has_new_edge = expected_has_new) - "ReactiveFixpoint.apply invariant failed: inconsistent edge_change") - edge_changes - - let assert_deleted_nodes_closed ~current ~deleted_nodes ~old_successors = - (* Invariant: [deleted_nodes ⊆ current] and - [k in deleted_nodes => old_successors(k) ∩ current ⊆ deleted_nodes]. *) + StableSet.iter_with check_deleted_node_closed t t.deleted_nodes + + (* Callback for assert_no_supported_deleted_left *) + let check_no_supported_deleted t k = + if not (StableSet.mem t.current k) then + assert_ + (not (is_supported t k)) + "ReactiveFixpoint.apply invariant failed: supported deleted node left \ + behind" + + let assert_no_supported_deleted_left t = if enabled then - Hashtbl.iter - (fun k () -> - assert_ (Hashtbl.mem current k) - "ReactiveFixpoint.apply invariant failed: deleted node not in \ - current"; - List.iter - (fun succ -> - if Hashtbl.mem current succ then - assert_ - (Hashtbl.mem deleted_nodes succ) - "ReactiveFixpoint.apply invariant failed: deleted closure \ - broken") - (old_successors k)) - deleted_nodes - - let assert_current_minus_deleted ~pre_current ~current ~deleted_nodes = - (* Invariant: [current = pre_current \\ deleted_nodes]. *) - if enabled then ( - let expected = copy_set pre_current in - Hashtbl.iter (fun k () -> Hashtbl.remove expected k) deleted_nodes; + StableSet.iter_with check_no_supported_deleted t t.deleted_nodes + + let remove_from_set dst k = StableSet.remove dst k + + let assert_current_minus_deleted ~pre_current ~expected t = + if enabled && Maybe.is_some pre_current && Maybe.is_some expected then ( + let pre_current = Maybe.unsafe_get pre_current in + let expected = Maybe.unsafe_get expected in + StableSet.copy ~dst:expected pre_current; + StableSet.iter_with remove_from_set expected t.deleted_nodes; assert_ - (set_equal expected current) + (StableSet.equal expected t.current) "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ deleted") - let assert_no_supported_deleted_left ~deleted_nodes ~current ~supported = - (* Invariant: [k in deleted_nodes \\ current => not (supported k)]. *) - if enabled then - Hashtbl.iter - (fun k () -> - if not (Hashtbl.mem current k) then - assert_ - (not (supported k)) - "ReactiveFixpoint.apply invariant failed: supported deleted node \ - left behind") - deleted_nodes - - let assert_removal_output_matches ~output_entries ~deleted_nodes ~current = - (* Invariant: [removal_keys(output_entries) = deleted_nodes \\ current]. *) - if enabled then ( - let expected = Hashtbl.create (Hashtbl.length deleted_nodes) in - Hashtbl.iter - (fun k () -> - if not (Hashtbl.mem current k) then Hashtbl.replace expected k ()) - deleted_nodes; - let actual = Hashtbl.create (List.length output_entries) in - List.iter - (fun (k, v_opt) -> if v_opt = None then Hashtbl.replace actual k ()) - output_entries; + (* Callbacks for assert_removal_output_matches / assert_final_fixpoint *) + let add_if_not_in_set ref_set dst k = + if not (StableSet.mem ref_set k) then StableSet.add dst k + + let add_to_set_if_none dst k mv = + if not (Maybe.is_some (Stable.to_linear_value mv)) then StableSet.add dst k + + let add_to_set_if_some dst k mv = + if Maybe.is_some (Stable.to_linear_value mv) then StableSet.add dst k + + let assert_removal_output_matches ~expected ~actual t = + if enabled && Maybe.is_some expected && Maybe.is_some actual then ( + let expected = Maybe.unsafe_get expected in + let actual = Maybe.unsafe_get actual in + StableSet.clear expected; + StableSet.iter_with2 add_if_not_in_set t.current expected t.deleted_nodes; + StableSet.clear actual; + StableWave.iter_with t.output_wave add_to_set_if_none actual; assert_ - (set_equal expected actual) + (StableSet.equal expected actual) "ReactiveFixpoint.apply invariant failed: removal output mismatch") - let assert_final_fixpoint_and_delta ~compute_reachable ~t ~pre_current - ~output_entries = - (* Invariant: [t.current = Reach(t.roots, t.edge_map)] and - [adds(output_entries) = t.current \\ pre_current] and - [removes(output_entries) = pre_current \\ t.current]. *) - if enabled then ( - let reachable = compute_reachable t in + let assert_final_fixpoint_and_delta ~pre_current ~expected ~actual t = + if + enabled && Maybe.is_some pre_current && Maybe.is_some expected + && Maybe.is_some actual + then ( + let pre_current = Maybe.unsafe_get pre_current in + let expected = Maybe.unsafe_get expected in + let actual = Maybe.unsafe_get actual in + fill_reachable_scratch t; assert_ - (set_equal reachable t.current) + (StableSet.equal t.metrics.scratch_reachable t.current) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; - - let expected_adds = Hashtbl.create (Hashtbl.length t.current) in - let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in - Hashtbl.iter - (fun k () -> - if not (Hashtbl.mem pre_current k) then - Hashtbl.replace expected_adds k ()) - t.current; - Hashtbl.iter - (fun k () -> - if not (Hashtbl.mem t.current k) then - Hashtbl.replace expected_removes k ()) - pre_current; - - let actual_adds = Hashtbl.create (List.length output_entries) in - let actual_removes = Hashtbl.create (List.length output_entries) in - List.iter - (fun (k, v_opt) -> - match v_opt with - | Some () -> Hashtbl.replace actual_adds k () - | None -> Hashtbl.replace actual_removes k ()) - output_entries; - - let adds_ok = set_equal expected_adds actual_adds in - let removes_ok = set_equal expected_removes actual_removes in + (* Check adds: nodes in current but not in pre_current *) + StableSet.clear expected; + StableSet.iter_with2 add_if_not_in_set pre_current expected t.current; + StableSet.clear actual; + StableWave.iter_with t.output_wave add_to_set_if_some actual; + let adds_ok = StableSet.equal expected actual in + (* Check removes: nodes in pre_current but not in current *) + StableSet.clear expected; + StableSet.iter_with2 add_if_not_in_set t.current expected pre_current; + StableSet.clear actual; + StableWave.iter_with t.output_wave add_to_set_if_none actual; + let removes_ok = StableSet.equal expected actual in if not (adds_ok && removes_ok) then failwith (Printf.sprintf "ReactiveFixpoint.apply invariant failed: output delta mismatch \ - (pre=%d final=%d output=%d expected_adds=%d actual_adds=%d \ - expected_removes=%d actual_removes=%d)" - (Hashtbl.length pre_current) - (Hashtbl.length t.current) - (List.length output_entries) - (Hashtbl.length expected_adds) - (Hashtbl.length actual_adds) - (Hashtbl.length expected_removes) - (Hashtbl.length actual_removes))) + (pre=%d final=%d output=%d)" + (StableSet.cardinal pre_current) + (StableSet.cardinal t.current) + (StableWave.count t.output_wave))) end -let create () = +let create ~max_nodes ~max_edges = + if max_nodes <= 0 then + invalid_arg "ReactiveFixpoint.create: max_nodes must be > 0"; + if max_edges <= 0 then + invalid_arg "ReactiveFixpoint.create: max_edges must be > 0"; { - current = Hashtbl.create 256; - edge_map = Hashtbl.create 256; - pred_map = Hashtbl.create 256; - roots = Hashtbl.create 64; + current = StableSet.create (); + edge_map = StableMap.create (); + pred_map = StableMapSet.create (); + roots = StableSet.create (); + output_wave = StableWave.create ~max_entries:max_nodes (); + deleted_nodes = StableSet.create (); + rederive_pending = StableSet.create (); + expansion_seen = StableSet.create (); + old_successors_for_changed = StableMap.create (); + scratch_set_a = StableSet.create (); + scratch_set_b = StableSet.create (); + edge_has_new = StableSet.create (); + delete_queue = StableQueue.create (); + rederive_queue = StableQueue.create (); + expansion_queue = StableQueue.create (); + added_roots_queue = StableQueue.create (); + edge_change_queue = StableQueue.create (); + new_successors_for_changed = StableMap.create (); + metrics = + { + delete_queue_pops = 0; + delete_edges_scanned = 0; + rederive_queue_pops = 0; + rederived_nodes = 0; + rederive_edges_scanned = 0; + expansion_queue_pops = 0; + expansion_edges_scanned = 0; + scratch_reachable = StableSet.create (); + }; } -let iter_current t f = Hashtbl.iter f t.current -let get_current t k = Hashtbl.find_opt t.current k -let current_length t = Hashtbl.length t.current - -let compute_reachable_from_roots t = - let reachable, _nodes, _edges = compute_reachable_from_roots_with_work t in - reachable - -let replace_current_with t new_current = - Hashtbl.reset t.current; - Hashtbl.iter (fun k v -> Hashtbl.replace t.current k v) new_current - -let add_pred t ~target ~pred = - let preds = - match Hashtbl.find_opt t.pred_map target with - | Some ps -> ps - | None -> - let ps = Hashtbl.create 4 in - Hashtbl.replace t.pred_map target ps; - ps - in - Hashtbl.replace preds pred () +let destroy t = + StableSet.destroy t.current; + StableMap.destroy t.edge_map; + StableMapSet.destroy t.pred_map; + StableSet.destroy t.roots; + StableSet.destroy t.deleted_nodes; + StableSet.destroy t.rederive_pending; + StableSet.destroy t.expansion_seen; + StableMap.destroy t.old_successors_for_changed; + StableMap.destroy t.new_successors_for_changed; + StableSet.destroy t.scratch_set_a; + StableSet.destroy t.scratch_set_b; + StableSet.destroy t.edge_has_new; + StableQueue.destroy t.delete_queue; + StableQueue.destroy t.rederive_queue; + StableQueue.destroy t.expansion_queue; + StableQueue.destroy t.added_roots_queue; + StableQueue.destroy t.edge_change_queue; + StableSet.destroy t.metrics.scratch_reachable; + StableWave.destroy t.output_wave +let output_wave t = t.output_wave + +type 'k root_wave = ('k, unit Maybe.t) StableWave.t +type 'k edge_wave = ('k, 'k StableList.t Maybe.t) StableWave.t +type 'k output_wave = ('k, unit Maybe.t) StableWave.t +type 'k root_snapshot = ('k, unit) StableWave.t +type 'k edge_snapshot = ('k, 'k StableList.t) StableWave.t + +let iter_current t f = + StableSet.iter_with (fun f k -> f k Stable.unit) f t.current + +let get_current t k = + if StableSet.mem t.current k then Maybe.some Stable.unit else Maybe.none + +let current_length t = StableSet.cardinal t.current + +let recompute_current t = ignore (compute_reachable ~visited:t.current t) + +let add_pred t ~target ~pred = StableMapSet.add t.pred_map target pred let remove_pred t ~target ~pred = - match Hashtbl.find_opt t.pred_map target with - | None -> () - | Some preds -> - Hashtbl.remove preds pred; - if Hashtbl.length preds = 0 then Hashtbl.remove t.pred_map target + StableMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred -exception Found_live_pred - -let has_live_predecessor t k = - match Hashtbl.find_opt t.pred_map k with - | None -> false - | Some preds -> ( - try - Hashtbl.iter - (fun pred () -> - if Hashtbl.mem t.current pred then raise Found_live_pred) - preds; - false - with Found_live_pred -> true) +let add_pred_for_src (t, src) target = add_pred t ~target ~pred:src +let remove_pred_for_src (t, src) target = remove_pred t ~target ~pred:src let apply_edge_update t ~src ~new_successors = - let old_successors = - match Hashtbl.find_opt t.edge_map src with - | Some succs -> succs - | None -> [] - in - match (old_successors, new_successors) with - | [], [] -> Hashtbl.remove t.edge_map src - | [], _ -> - List.iter (fun target -> add_pred t ~target ~pred:src) new_successors; - Hashtbl.replace t.edge_map src new_successors - | _, [] -> - List.iter (fun target -> remove_pred t ~target ~pred:src) old_successors; - Hashtbl.remove t.edge_map src - | _, _ -> - let new_set = Hashtbl.create (List.length new_successors) in - List.iter (fun k -> Hashtbl.replace new_set k ()) new_successors; - - let old_set = Hashtbl.create (List.length old_successors) in - List.iter (fun k -> Hashtbl.replace old_set k ()) old_successors; - - List.iter - (fun target -> - if not (Hashtbl.mem new_set target) then remove_pred t ~target ~pred:src) - old_successors; - - List.iter - (fun target -> - if not (Hashtbl.mem old_set target) then add_pred t ~target ~pred:src) - new_successors; - - Hashtbl.replace t.edge_map src new_successors - -let initialize t ~roots_iter ~edges_iter = - Hashtbl.reset t.roots; - Hashtbl.reset t.edge_map; - Hashtbl.reset t.pred_map; - roots_iter (fun k () -> Hashtbl.replace t.roots k ()); - edges_iter (fun k successors -> - apply_edge_update t ~src:k ~new_successors:successors); - replace_current_with t (compute_reachable_from_roots t) - -let apply t ~init_entries ~edge_entries = + let old_successors = find_succs t.edge_map src in + if StableList.is_empty old_successors && StableList.is_empty new_successors + then StableMap.remove t.edge_map src + else if StableList.is_empty old_successors then ( + StableList.iter_with add_pred_for_src (t, src) new_successors; + StableMap.replace t.edge_map src (StableList.to_stable new_successors)) + else if StableList.is_empty new_successors then ( + StableList.iter_with remove_pred_for_src (t, src) old_successors; + StableMap.remove t.edge_map src) + else ( + StableSet.clear t.scratch_set_a; + StableSet.clear t.scratch_set_b; + StableList.iter (fun k -> StableSet.add t.scratch_set_a k) new_successors; + StableList.iter (fun k -> StableSet.add t.scratch_set_b k) old_successors; + + StableList.iter_with + (fun () target -> + if not (StableSet.mem t.scratch_set_a target) then + remove_pred t ~target ~pred:src) + () old_successors; + + StableList.iter_with + (fun () target -> + if not (StableSet.mem t.scratch_set_b target) then + add_pred t ~target ~pred:src) + () new_successors; + + StableMap.replace t.edge_map src (StableList.to_stable new_successors)) + +let initialize t ~roots ~edges = + StableSet.clear t.roots; + StableMap.clear t.edge_map; + StableMapSet.clear t.pred_map; + StableWave.iter roots (fun k _ -> StableSet.add t.roots k); + StableWave.iter edges (fun k successors -> + apply_edge_update t ~src:k ~new_successors:(succs_of_stable successors)); + recompute_current t + +let mark_deleted t k = + if StableSet.mem t.current k && not (StableSet.mem t.deleted_nodes k) then ( + StableSet.add t.deleted_nodes k; + enqueue t.delete_queue k) + +let enqueue_expand t k = + if StableSet.mem t.current k && not (StableSet.mem t.expansion_seen k) then ( + StableSet.add t.expansion_seen k; + enqueue t.expansion_queue k) + +let add_live t k = + if not (StableSet.mem t.current k) then ( + StableSet.add t.current k; + if not (StableSet.mem t.deleted_nodes k) then + StableWave.push t.output_wave k (Maybe.to_stable (Maybe.some Stable.unit)); + enqueue_expand t k) + +let enqueue_rederive_if_needed t k = + if + StableSet.mem t.deleted_nodes k + && (not (StableSet.mem t.current k)) + && (not (StableSet.mem t.rederive_pending k)) + && is_supported t k + then ( + StableSet.add t.rederive_pending k; + enqueue t.rederive_queue k) + +let scan_root_entry t k mv = + let had_root = StableSet.mem t.roots k in + if Maybe.is_some mv then (if not had_root then enqueue t.added_roots_queue k) + else if had_root then mark_deleted t k + +let mark_deleted_if_absent (t, set) k = + if not (StableSet.mem set k) then mark_deleted t k + +let mark_deleted_unless_in_set t set xs = + StableList.iter_with mark_deleted_if_absent (t, set) xs + +let exists_not_in_set set xs = StableList.exists_with not_in_set set xs + +let scan_edge_entry t src mv = + let old_succs = find_succs t.edge_map src in + let new_succs = succs_of_maybe mv in + StableMap.replace t.old_successors_for_changed src + (StableList.to_stable old_succs); + StableMap.replace t.new_successors_for_changed src + (StableList.to_stable new_succs); + enqueue t.edge_change_queue src; + let src_is_live = StableSet.mem t.current src in + match (old_succs, new_succs) with + | _ when StableList.is_empty old_succs && StableList.is_empty new_succs -> () + | _ when StableList.is_empty old_succs -> StableSet.add t.edge_has_new src + | _ when StableList.is_empty new_succs -> + if src_is_live then StableList.iter_with mark_deleted t old_succs + | _ -> + StableSet.clear t.scratch_set_a; + StableSet.clear t.scratch_set_b; + StableList.iter_with set_add_k t.scratch_set_a new_succs; + StableList.iter_with set_add_k t.scratch_set_b old_succs; + if src_is_live then mark_deleted_unless_in_set t t.scratch_set_a old_succs; + if exists_not_in_set t.scratch_set_b new_succs then + StableSet.add t.edge_has_new src + +let apply_root_mutation t k mv = + if Maybe.is_some mv then StableSet.add t.roots k + else StableSet.remove t.roots k + +let emit_removal t k () = + if not (StableSet.mem t.current k) then + StableWave.push t.output_wave k Maybe.none_stable + +let rebuild_edge_change_queue t src _succs = + StableQueue.push t.edge_change_queue src + +let remove_from_current t k = StableSet.remove t.current k + +let enqueue_rederive_if_needed_kv t k = enqueue_rederive_if_needed t k + +let apply_list t ~roots ~edges = + (* Create scratch sets for invariant checks — only real when enabled *) let pre_current = - if Invariants.enabled then Some (Invariants.copy_set t.current) else None + if Invariants.enabled then Maybe.some (StableSet.create ()) else Maybe.none in - let output_entries = ref [] in - let removed_roots = ref [] in - let added_roots = ref [] in - let edge_changes : 'k edge_change list ref = ref [] in - - List.iter - (fun (k, v_opt) -> - let had_root = Hashtbl.mem t.roots k in - match v_opt with - | Some () -> if not had_root then added_roots := k :: !added_roots - | None -> if had_root then removed_roots := k :: !removed_roots) - init_entries; - - let old_successors_for_changed : ('k, 'k list) Hashtbl.t = - Hashtbl.create 64 + let expected = + if Invariants.enabled then Maybe.some (StableSet.create ()) else Maybe.none in - - List.iter - (fun (src, v_opt) -> - let old_succs = - match Hashtbl.find_opt t.edge_map src with - | Some succs -> succs - | None -> [] - in - let new_succs = - match v_opt with - | Some succs -> succs - | None -> [] - in - let removed_targets, has_new_edge = - analyze_edge_change ~old_succs ~new_succs - in - Hashtbl.replace old_successors_for_changed src old_succs; - edge_changes := - {src; old_succs; new_succs; removed_targets; has_new_edge} - :: !edge_changes) - edge_entries; - Invariants.assert_edge_changes_consistent !edge_changes; - - let deleted_nodes : ('k, unit) Hashtbl.t = Hashtbl.create 128 in - let delete_queue = Queue.create () in - let delete_queue_pops = ref 0 in - let delete_edges_scanned = ref 0 in - - let mark_deleted k = - if Hashtbl.mem t.current k && not (Hashtbl.mem deleted_nodes k) then ( - Hashtbl.replace deleted_nodes k (); - Queue.add k delete_queue) + let actual = + if Invariants.enabled then Maybe.some (StableSet.create ()) else Maybe.none in + if Invariants.enabled then + StableSet.copy ~dst:(Maybe.unsafe_get pre_current) t.current; + (* Clear all scratch state up front *) + StableSet.clear t.deleted_nodes; + StableQueue.clear t.delete_queue; + StableQueue.clear t.added_roots_queue; + StableQueue.clear t.edge_change_queue; + StableMap.clear t.old_successors_for_changed; + StableMap.clear t.new_successors_for_changed; + StableSet.clear t.edge_has_new; + let m = t.metrics in + Metrics.reset_per_call m; + + (* Phase 1a: scan init entries — seed delete queue for removed roots, + buffer added roots for later expansion *) + StableWave.iter_with roots + (fun t k mv -> scan_root_entry t k (Stable.to_linear_value mv)) + t; + + (* Phase 1b: scan edge entries — seed delete queue for removed targets, + store new_succs and has_new_edge for later phases *) + StableWave.iter_with edges + (fun t src mv -> scan_edge_entry t src (Maybe.of_stable mv)) + t; + + Invariants.assert_edge_has_new_consistent expected t; + + (* Phase 2: delete BFS *) + while not (StableQueue.is_empty t.delete_queue) do + let k = StableQueue.pop t.delete_queue in + let succs = old_successors t k in + if Metrics.enabled then ( + m.delete_queue_pops <- m.delete_queue_pops + 1; + m.delete_edges_scanned <- m.delete_edges_scanned + StableList.length succs); + StableList.iter_with mark_deleted t succs + done; + Invariants.assert_deleted_nodes_closed t; + + (* Phase 3: apply root and edge mutations *) + StableWave.iter_with roots + (fun t k mv -> apply_root_mutation t k (Stable.to_linear_value mv)) + t; + + (* Apply edge updates by draining edge_change_queue. *) + while not (StableQueue.is_empty t.edge_change_queue) do + let src = StableQueue.pop t.edge_change_queue in + let new_succs = find_succs t.new_successors_for_changed src in + apply_edge_update t ~src ~new_successors:new_succs + done; + (* Rebuild edge_change_queue from new_successors_for_changed keys for + use in expansion seeding below *) + StableMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; - List.iter mark_deleted !removed_roots; - - List.iter - (fun {src; removed_targets; _} -> - if Hashtbl.mem t.current src then - List.iter (fun target -> mark_deleted target) removed_targets) - !edge_changes; - - let old_successors k = - match Hashtbl.find_opt old_successors_for_changed k with - | Some succs -> succs - | None -> ( - match Hashtbl.find_opt t.edge_map k with - | Some succs -> succs - | None -> []) - in + StableSet.iter_with remove_from_current t t.deleted_nodes; + Invariants.assert_current_minus_deleted ~pre_current ~expected t; - while not (Queue.is_empty delete_queue) do - let k = Queue.pop delete_queue in - incr delete_queue_pops; - let succs = old_successors k in - delete_edges_scanned := !delete_edges_scanned + List.length succs; - List.iter mark_deleted succs - done; - Invariants.assert_deleted_nodes_closed ~current:t.current ~deleted_nodes - ~old_successors; - - List.iter - (fun (k, v_opt) -> - match v_opt with - | Some () -> Hashtbl.replace t.roots k () - | None -> Hashtbl.remove t.roots k) - init_entries; - - List.iter - (fun {src; new_succs; _} -> - apply_edge_update t ~src ~new_successors:new_succs) - !edge_changes; - - Hashtbl.iter (fun k () -> Hashtbl.remove t.current k) deleted_nodes; - (match pre_current with - | Some pre -> - Invariants.assert_current_minus_deleted ~pre_current:pre ~current:t.current - ~deleted_nodes - | None -> ()); - - let supported k = Hashtbl.mem t.roots k || has_live_predecessor t k in - - let rederive_queue = Queue.create () in - let rederive_pending : ('k, unit) Hashtbl.t = Hashtbl.create 128 in - let rederive_queue_pops = ref 0 in - let rederived_nodes = ref 0 in - let rederive_edges_scanned = ref 0 in - - let enqueue_rederive_if_needed k = - if - Hashtbl.mem deleted_nodes k - && (not (Hashtbl.mem t.current k)) - && (not (Hashtbl.mem rederive_pending k)) - && supported k - then ( - Hashtbl.replace rederive_pending k (); - Queue.add k rederive_queue) - in + (* Phase 4: rederive *) + StableQueue.clear t.rederive_queue; + StableSet.clear t.rederive_pending; - Hashtbl.iter (fun k () -> enqueue_rederive_if_needed k) deleted_nodes; + StableSet.iter_with + (fun t k -> enqueue_rederive_if_needed_kv t k) + t t.deleted_nodes; - while not (Queue.is_empty rederive_queue) do - let k = Queue.pop rederive_queue in - incr rederive_queue_pops; - Hashtbl.remove rederive_pending k; + while not (StableQueue.is_empty t.rederive_queue) do + let k = StableQueue.pop t.rederive_queue in + if Metrics.enabled then m.rederive_queue_pops <- m.rederive_queue_pops + 1; + StableSet.remove t.rederive_pending k; if - Hashtbl.mem deleted_nodes k - && (not (Hashtbl.mem t.current k)) - && supported k + StableSet.mem t.deleted_nodes k + && (not (StableSet.mem t.current k)) + && is_supported t k then ( - Hashtbl.replace t.current k (); - incr rederived_nodes; - match Hashtbl.find_opt t.edge_map k with - | None -> () - | Some succs -> - rederive_edges_scanned := !rederive_edges_scanned + List.length succs; - List.iter enqueue_rederive_if_needed succs) + StableSet.add t.current k; + if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; + let r = StableMap.find_maybe t.edge_map k in + if Maybe.is_some r then ( + let succs = succs_of_stable (Maybe.unsafe_get r) in + if Metrics.enabled then + m.rederive_edges_scanned <- + m.rederive_edges_scanned + StableList.length succs; + StableList.iter_with enqueue_rederive_if_needed t succs)) done; - Invariants.assert_no_supported_deleted_left ~deleted_nodes ~current:t.current - ~supported; - - let expansion_queue = Queue.create () in - let expansion_seen : ('k, unit) Hashtbl.t = Hashtbl.create 128 in - let expansion_queue_pops = ref 0 in - let expansion_edges_scanned = ref 0 in - - let enqueue_expand k = - if Hashtbl.mem t.current k && not (Hashtbl.mem expansion_seen k) then ( - Hashtbl.replace expansion_seen k (); - Queue.add k expansion_queue) - in + Invariants.assert_no_supported_deleted_left t; - let add_live k = - if not (Hashtbl.mem t.current k) then ( - Hashtbl.replace t.current k (); - (* If a node was tentatively deleted in this wave and later rederived, - suppress add output so downstream sees no net change for that key. *) - if not (Hashtbl.mem deleted_nodes k) then - output_entries := (k, Some ()) :: !output_entries; - enqueue_expand k) - in + (* Phase 5: expansion *) + StableQueue.clear t.expansion_queue; + StableSet.clear t.expansion_seen; - List.iter add_live !added_roots; - - List.iter - (fun {src; has_new_edge; _} -> - if Hashtbl.mem t.current src && has_new_edge then enqueue_expand src) - !edge_changes; - - while not (Queue.is_empty expansion_queue) do - let k = Queue.pop expansion_queue in - incr expansion_queue_pops; - match Hashtbl.find_opt t.edge_map k with - | None -> () - | Some successors -> - expansion_edges_scanned := - !expansion_edges_scanned + List.length successors; - List.iter add_live successors + (* Seed expansion from added roots *) + while not (StableQueue.is_empty t.added_roots_queue) do + add_live t (StableQueue.pop t.added_roots_queue) done; - Hashtbl.iter - (fun k () -> - if not (Hashtbl.mem t.current k) then - output_entries := (k, None) :: !output_entries) - deleted_nodes; - Invariants.assert_removal_output_matches ~output_entries:!output_entries - ~deleted_nodes ~current:t.current; - (match pre_current with - | Some pre -> - Invariants.assert_final_fixpoint_and_delta - ~compute_reachable:compute_reachable_from_roots ~t ~pre_current:pre - ~output_entries:!output_entries - | None -> ()); - - (if Metrics.enabled then - (* Metrics mode intentionally computes a full closure baseline to compare - incremental work against full recomputation. Keep this opt-in only. *) - let _full_reachable, full_node_work, full_edge_work = - compute_reachable_from_roots_with_work t - in - let incr_node_work = - List.length init_entries + List.length edge_entries + !delete_queue_pops - + !rederive_queue_pops + !expansion_queue_pops - in - let incr_edge_work = - !delete_edges_scanned + !rederive_edges_scanned - + !expansion_edges_scanned - in - Metrics.update ~init_entries:(List.length init_entries) - ~edge_entries:(List.length edge_entries) - ~output_entries:(List.length !output_entries) - ~deleted_nodes:(Hashtbl.length deleted_nodes) - ~rederived_nodes:!rederived_nodes ~incr_node_work ~incr_edge_work - ~full_node_work ~full_edge_work); - - !output_entries + + (* Seed expansion from edge changes with new edges *) + while not (StableQueue.is_empty t.edge_change_queue) do + let src = StableQueue.pop t.edge_change_queue in + if StableSet.mem t.current src && StableSet.mem t.edge_has_new src then + enqueue_expand t src + done; + + while not (StableQueue.is_empty t.expansion_queue) do + let k = StableQueue.pop t.expansion_queue in + if Metrics.enabled then m.expansion_queue_pops <- m.expansion_queue_pops + 1; + let r = StableMap.find_maybe t.edge_map k in + if Maybe.is_some r then ( + let succs = succs_of_stable (Maybe.unsafe_get r) in + if Metrics.enabled then + m.expansion_edges_scanned <- + m.expansion_edges_scanned + StableList.length succs; + StableList.iter_with add_live t succs) + done; + StableSet.iter_with (fun t k -> emit_removal t k ()) t t.deleted_nodes; + Invariants.assert_removal_output_matches ~expected ~actual t; + Invariants.assert_final_fixpoint_and_delta ~pre_current ~expected ~actual t; + if Invariants.enabled then ( + StableSet.destroy (Maybe.unsafe_get pre_current); + StableSet.destroy (Maybe.unsafe_get expected); + StableSet.destroy (Maybe.unsafe_get actual)); + + if Metrics.enabled then + let full_node_work, full_edge_work = + compute_reachable ~visited:t.metrics.scratch_reachable t + in + let init_count = StableWave.count roots in + let edge_count = StableWave.count edges in + let incr_node_work = + init_count + edge_count + m.delete_queue_pops + m.rederive_queue_pops + + m.expansion_queue_pops + in + let incr_edge_work = + m.delete_edges_scanned + m.rederive_edges_scanned + + m.expansion_edges_scanned + in + Metrics.update ~init_entries:init_count ~edge_entries:edge_count + ~output_entries:(StableWave.count t.output_wave) + ~deleted_nodes:(StableSet.cardinal t.deleted_nodes) + ~rederived_nodes:m.rederived_nodes ~incr_node_work ~incr_edge_work + ~full_node_work ~full_edge_work + +let apply_wave t ~roots ~edges = + StableWave.clear t.output_wave; + apply_list t ~roots ~edges; + () diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 2b68c56ad8..ccb9a85c37 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -1,63 +1,37 @@ type 'k t (** Internal state for incremental transitive-closure computation. - High-level model: - - Root set [R : 'k set] - - Edge relation [E : 'k -> 'k list] - - Current reachable set [C : 'k set] + This implementation uses fixed-capacity arrays allocated in [create]. *) - Fundamental invariant: - [C = Reach(R, E)], where [Reach] is the least fixed point of reachability - from roots through directed edges. *) +type 'k root_wave = ('k, unit Maybe.t) StableWave.t +type 'k edge_wave = ('k, 'k StableList.t Maybe.t) StableWave.t +type 'k output_wave = ('k, unit Maybe.t) StableWave.t +type 'k root_snapshot = ('k, unit) StableWave.t +type 'k edge_snapshot = ('k, 'k StableList.t) StableWave.t -val create : unit -> 'k t -(** Create an empty state. - Postcondition: [R = empty], [E = empty], [C = empty]. *) +val create : max_nodes:int -> max_edges:int -> 'k t +(** Create an empty state with fixed capacities. -val iter_current : 'k t -> ('k -> unit -> unit) -> unit -(** Iterate keys currently in [C]. - Order is unspecified. *) + Raises [Invalid_argument] if capacities are not positive. *) -val get_current : 'k t -> 'k -> unit option -(** Membership query for [C]. - Returns [Some ()] iff the key is currently reachable, [None] otherwise. *) +val destroy : 'k t -> unit +(** Release fixpoint-owned stable storage. The state must not be used + afterwards. *) +val output_wave : 'k t -> 'k output_wave +(** The owned output wave populated by [apply_wave]. *) + +val iter_current : 'k t -> ('k Stable.t -> unit Stable.t -> unit) -> unit +val get_current : 'k t -> 'k Stable.t -> unit Stable.t Maybe.t val current_length : 'k t -> int -(** Cardinality of [C]. *) val initialize : - 'k t -> - roots_iter:(('k -> unit -> unit) -> unit) -> - edges_iter:(('k -> 'k list -> unit) -> unit) -> - unit -(** Replace [R] and [E] from iterators (full overwrite), then recompute closure. - Postcondition: [C := Reach(R, E)]. *) - -val apply : - 'k t -> - init_entries:('k * unit option) list -> - edge_entries:('k * 'k list option) list -> - ('k * unit option) list -(** Apply one incremental update wave and return closure deltas. - - Input semantics: - - [init_entries]: root updates, where [(k, Some ())] adds/presents root [k] - and [(k, None)] removes root [k]. - - [edge_entries]: outgoing-edge updates, where [(k, Some succs)] sets - [E(k) := succs] and [(k, None)] removes [k]'s edge entry. - - Correctness postcondition: - - Let pre-state be [(R0, E0, C0)] and post-state [(R1, E1, C1)] after the - updates. Then [C1 = Reach(R1, E1)]. - - Returned entries encode the set delta [C0 -> C1]: - [(k, Some ())] iff [k in (C1 \\ C0)], - [(k, None)] iff [k in (C0 \\ C1)]. - - Net-effect rule: - - If a key is tentatively deleted and rederived within the same wave, no - remove/add pair is emitted for that key. - - Notes: - - Output entry order is unspecified. - - Callers should provide at most one update per key per call (or - deduplicate before calling). *) + 'k t -> roots:'k root_snapshot -> edges:'k edge_snapshot -> unit +(** Replace roots and edges from snapshots (full overwrite), then recompute + closure. *) + +val apply_wave : 'k t -> roots:'k root_wave -> edges:'k edge_wave -> unit +(** Apply one incremental update wave and populate the owned output wave. + + Duplicate updates for the same key in one call are coalesced + (last-write-wins). *) diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml new file mode 100644 index 0000000000..6a68b92518 --- /dev/null +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -0,0 +1,161 @@ +(** Zero-allocation (steady-state) flatMap state and processing logic. *) + +type ('k1, 'v1, 'k2, 'v2) t = { + f: 'k1 Stable.t -> 'v1 Stable.t -> ('k2, 'v2) StableWave.t -> unit; + merge: 'v2 Stable.t -> 'v2 Stable.t -> 'v2 Stable.t; + (* Persistent state *) + provenance: ('k1, 'k2) StableMapSet.t; + contributions: ('k2, 'k1, 'v2) StableMapMap.t; + target: ('k2, 'v2) StableMap.t; + (* Scratch — allocated once, cleared per process() *) + scratch: ('k1, 'v1 Maybe.t) StableMap.t; + affected: 'k2 StableSet.t; + (* Pre-allocated output buffer *) + output_wave: ('k2, 'v2 Maybe.t) StableWave.t; + (* Pre-allocated buffer for f's emissions *) + emit_wave: ('k2, 'v2) StableWave.t; + (* Set before drain_key callback — identifies source being removed/emitted *) + mutable current_k1: 'k1 Stable.t Maybe.t; + (* Mutable stats — allocated once, returned by process() *) + result: process_result; + (* Merge accumulator for recompute_target — Maybe.none = first element *) + mutable merge_acc: 'v2 Stable.t Maybe.t; +} + +and process_result = { + mutable entries_received: int; + mutable adds_received: int; + mutable removes_received: int; + mutable entries_emitted: int; + mutable adds_emitted: int; + mutable removes_emitted: int; +} + +(* Record one contribution from the emit wave *) +let record_contribution (t : (_, _, _, _) t) k2 v2 = + let k1 = Maybe.unsafe_get t.current_k1 in + StableMapSet.add t.provenance k1 k2; + StableMapMap.replace t.contributions k2 k1 v2; + StableSet.add t.affected k2 + +(* Record one contribution and write directly to target (init path) *) +let record_contribution_init (t : (_, _, _, _) t) k2 v2 = + let k1 = Maybe.unsafe_get t.current_k1 in + StableMapSet.add t.provenance k1 k2; + StableMapMap.replace t.contributions k2 k1 v2; + StableMap.replace t.target k2 v2 + +let create ~f ~merge = + { + f; + merge; + provenance = StableMapSet.create (); + contributions = StableMapMap.create (); + target = StableMap.create (); + scratch = StableMap.create (); + affected = StableSet.create (); + output_wave = StableWave.create (); + emit_wave = StableWave.create (); + current_k1 = Maybe.none; + result = + { + entries_received = 0; + adds_received = 0; + removes_received = 0; + entries_emitted = 0; + adds_emitted = 0; + removes_emitted = 0; + }; + merge_acc = Maybe.none; + } + +let destroy t = + StableMapSet.destroy t.provenance; + StableMapMap.destroy t.contributions; + StableMap.destroy t.target; + StableMap.destroy t.scratch; + StableSet.destroy t.affected; + StableWave.destroy t.output_wave; + StableWave.destroy t.emit_wave + +let output_wave t = t.output_wave + +let push t k v_opt = StableMap.replace t.scratch k v_opt + +(* Remove one contribution key during remove_source iteration *) +let remove_one_contribution (t : (_, _, _, _) t) k2 = + StableMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 + (Maybe.unsafe_get t.current_k1); + StableSet.add t.affected k2 + +let remove_source (t : (_, _, _, _) t) k1 = + t.current_k1 <- Maybe.some k1; + StableMapSet.drain_key t.provenance k1 t remove_one_contribution + +(* Merge callback for recompute_target iter_with *) +let merge_one_contribution (t : (_, _, _, _) t) _k1 v = + if Maybe.is_none t.merge_acc then t.merge_acc <- Maybe.some v + else t.merge_acc <- Maybe.some (t.merge (Maybe.unsafe_get t.merge_acc) v) + +let recompute_target (t : (_, _, _, _) t) k2 = + if StableMapMap.inner_cardinal t.contributions k2 > 0 then ( + t.merge_acc <- Maybe.none; + StableMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; + StableMap.replace t.target k2 (Maybe.unsafe_get t.merge_acc); + StableWave.push t.output_wave k2 (Maybe.to_stable t.merge_acc)) + else ( + StableMap.remove t.target k2; + StableWave.push t.output_wave k2 Maybe.none_stable) + +(* Single-pass process + count for scratch *) +let process_scratch_entry (t : (_, _, _, _) t) k1 mv = + let mv = Maybe.of_stable mv in + t.result.entries_received <- t.result.entries_received + 1; + remove_source t k1; + if Maybe.is_some mv then ( + t.result.adds_received <- t.result.adds_received + 1; + let v1 = Maybe.unsafe_get mv in + t.current_k1 <- Maybe.some k1; + StableWave.clear t.emit_wave; + t.f k1 v1 t.emit_wave; + StableWave.iter_with t.emit_wave record_contribution t) + else t.result.removes_received <- t.result.removes_received + 1 + +let count_output_entry (r : process_result) _k mv = + let mv = Maybe.of_stable mv in + if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 + else r.removes_emitted <- r.removes_emitted + 1 + +let process (t : (_, _, _, _) t) = + let r = t.result in + r.entries_received <- 0; + r.adds_received <- 0; + r.removes_received <- 0; + r.adds_emitted <- 0; + r.removes_emitted <- 0; + + StableSet.clear t.affected; + StableWave.clear t.output_wave; + + StableMap.iter_with process_scratch_entry t t.scratch; + StableMap.clear t.scratch; + + StableSet.iter_with recompute_target t t.affected; + + let num_entries = StableWave.count t.output_wave in + r.entries_emitted <- num_entries; + if num_entries > 0 then + StableWave.iter_with t.output_wave count_output_entry r; + r + +let init_entry (t : (_, _, _, _) t) k1 v1 = + t.current_k1 <- Maybe.some k1; + StableWave.clear t.emit_wave; + t.f k1 v1 t.emit_wave; + StableWave.iter_with t.emit_wave record_contribution_init t + +let iter_target f t = StableMap.iter f t.target + +let find_target t k = StableMap.find_maybe t.target k + +let target_length t = StableMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli new file mode 100644 index 0000000000..e9ef8b5310 --- /dev/null +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -0,0 +1,43 @@ +(** Zero-allocation (steady-state) flatMap state and processing logic. + + This module is used by {!Reactive.FlatMap.create}. *) + +type ('k1, 'v1, 'k2, 'v2) t + +type process_result = { + mutable entries_received: int; + mutable adds_received: int; + mutable removes_received: int; + mutable entries_emitted: int; + mutable adds_emitted: int; + mutable removes_emitted: int; +} + +val create : + f:('k1 Stable.t -> 'v1 Stable.t -> ('k2, 'v2) StableWave.t -> unit) -> + merge:('v2 Stable.t -> 'v2 Stable.t -> 'v2 Stable.t) -> + ('k1, 'v1, 'k2, 'v2) t + +val destroy : ('k1, 'v1, 'k2, 'v2) t -> unit +(** Release flatMap-owned stable storage. The state must not be used + afterwards. *) + +val output_wave : ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 Maybe.t) StableWave.t +(** The owned output wave populated by [process]. *) + +val push : + ('k1, 'v1, 'k2, 'v2) t -> 'k1 Stable.t -> 'v1 Maybe.t Stable.t -> unit +(** Push an entry into the scratch table. *) + +val process : ('k1, 'v1, 'k2, 'v2) t -> process_result +(** Process accumulated scratch entries, update target, populate output wave. + Returns stats for the caller to apply. The output wave is populated + (and can be sent to subscribers) only when [entries_emitted > 0]. *) + +val init_entry : ('k1, 'v1, 'k2, 'v2) t -> 'k1 Stable.t -> 'v1 Stable.t -> unit +(** Initialize from an existing source entry (during setup). *) + +val iter_target : + ('k2 Stable.t -> 'v2 Stable.t -> unit) -> ('k1, 'v1, 'k2, 'v2) t -> unit +val find_target : ('k1, 'v1, 'k2, 'v2) t -> 'k2 Stable.t -> 'v2 Stable.t Maybe.t +val target_length : ('k1, 'v1, 'k2, 'v2) t -> int diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml new file mode 100644 index 0000000000..de699b69bc --- /dev/null +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -0,0 +1,230 @@ +(** Zero-allocation (steady-state) join state and processing logic. *) + +type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { + key_of: 'k1 Stable.t -> 'v1 Stable.t -> 'k2 Stable.t; + f: + 'k1 Stable.t -> + 'v1 Stable.t -> + 'v2 Stable.t Maybe.t -> + ('k3, 'v3) StableWave.t -> + unit; + merge: 'v3 Stable.t -> 'v3 Stable.t -> 'v3 Stable.t; + right_get: 'k2 Stable.t -> 'v2 Stable.t Maybe.t; + (* Persistent state *) + left_entries: ('k1, 'v1) StableMap.t; + provenance: ('k1, 'k3) StableMapSet.t; + contributions: ('k3, 'k1, 'v3) StableMapMap.t; + target: ('k3, 'v3) StableMap.t; + left_to_right_key: ('k1, 'k2) StableMap.t; + right_key_to_left_keys: ('k2, 'k1) StableMapSet.t; + (* Scratch — allocated once, cleared per process() *) + left_scratch: ('k1, 'v1 Maybe.t) StableMap.t; + right_scratch: ('k2, 'v2 Maybe.t) StableMap.t; + affected: 'k3 StableSet.t; + (* Pre-allocated output buffer *) + output_wave: ('k3, 'v3 Maybe.t) StableWave.t; + (* Pre-allocated buffer for f's emissions *) + emit_wave: ('k3, 'v3) StableWave.t; + (* Set before drain_key / emit_wave iteration *) + mutable current_k1: 'k1 Stable.t Maybe.t; + (* Mutable stats — allocated once, returned by process() *) + result: process_result; + (* Merge accumulator for recompute_target — Maybe.none = first element *) + mutable merge_acc: 'v3 Stable.t Maybe.t; +} + +and process_result = { + mutable entries_received: int; + mutable adds_received: int; + mutable removes_received: int; + mutable entries_emitted: int; + mutable adds_emitted: int; + mutable removes_emitted: int; +} + +(* Record one contribution from the emit wave — marks affected *) +let record_contribution (t : (_, _, _, _, _, _) t) k3 v3 = + let k1 = Maybe.unsafe_get t.current_k1 in + StableMapSet.add t.provenance k1 k3; + StableMapMap.replace t.contributions k3 k1 v3; + StableSet.add t.affected k3 + +(* Record one contribution and write directly to target (init path) *) +let record_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = + let k1 = Maybe.unsafe_get t.current_k1 in + StableMapSet.add t.provenance k1 k3; + StableMapMap.replace t.contributions k3 k1 v3; + StableMap.replace t.target k3 v3 + +let create ~key_of ~f ~merge ~right_get = + { + key_of; + f; + merge; + right_get; + left_entries = StableMap.create (); + provenance = StableMapSet.create (); + contributions = StableMapMap.create (); + target = StableMap.create (); + left_to_right_key = StableMap.create (); + right_key_to_left_keys = StableMapSet.create (); + left_scratch = StableMap.create (); + right_scratch = StableMap.create (); + affected = StableSet.create (); + output_wave = StableWave.create (); + emit_wave = StableWave.create (); + current_k1 = Maybe.none; + result = + { + entries_received = 0; + adds_received = 0; + removes_received = 0; + entries_emitted = 0; + adds_emitted = 0; + removes_emitted = 0; + }; + merge_acc = Maybe.none; + } + +let destroy t = + StableMap.destroy t.left_entries; + StableMapSet.destroy t.provenance; + StableMapMap.destroy t.contributions; + StableMap.destroy t.target; + StableMap.destroy t.left_to_right_key; + StableMapSet.destroy t.right_key_to_left_keys; + StableMap.destroy t.left_scratch; + StableMap.destroy t.right_scratch; + StableSet.destroy t.affected; + StableWave.destroy t.output_wave; + StableWave.destroy t.emit_wave + +let output_wave t = t.output_wave + +let push_left t k v_opt = StableMap.replace t.left_scratch k v_opt + +let push_right t k v_opt = StableMap.replace t.right_scratch k v_opt + +(* Remove one contribution key during remove_left_contributions iteration *) +let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = + StableMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 + (Maybe.unsafe_get t.current_k1); + StableSet.add t.affected k3 + +let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = + t.current_k1 <- Maybe.some k1; + StableMapSet.drain_key t.provenance k1 t remove_one_contribution_key + +let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = + let mb = StableMap.find_maybe t.left_to_right_key k1 in + if Maybe.is_some mb then ( + let old_k2 = Maybe.unsafe_get mb in + StableMap.remove t.left_to_right_key k1; + StableMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys + old_k2 k1) + +let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = + remove_left_contributions t k1; + unlink_right_key t k1; + let k2 = t.key_of k1 v1 in + StableMap.replace t.left_to_right_key k1 k2; + StableMapSet.add t.right_key_to_left_keys k2 k1; + let right_val = t.right_get k2 in + t.current_k1 <- Maybe.some k1; + StableWave.clear t.emit_wave; + t.f k1 v1 right_val t.emit_wave; + StableWave.iter_with t.emit_wave record_contribution t + +let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = + StableMap.remove t.left_entries k1; + remove_left_contributions t k1; + unlink_right_key t k1 + +(* Merge callback for recompute_target iter_with *) +let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = + if Maybe.is_none t.merge_acc then t.merge_acc <- Maybe.some v + else t.merge_acc <- Maybe.some (t.merge (Maybe.unsafe_get t.merge_acc) v) + +let recompute_target (t : (_, _, _, _, _, _) t) k3 = + if StableMapMap.inner_cardinal t.contributions k3 > 0 then ( + t.merge_acc <- Maybe.none; + StableMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; + StableMap.replace t.target k3 (Maybe.unsafe_get t.merge_acc); + StableWave.push t.output_wave k3 (Maybe.to_stable t.merge_acc)) + else ( + StableMap.remove t.target k3; + StableWave.push t.output_wave k3 Maybe.none_stable) + +(* Single-pass process + count for left scratch *) +let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = + let mv = Maybe.of_stable mv in + t.result.entries_received <- t.result.entries_received + 1; + if Maybe.is_some mv then ( + t.result.adds_received <- t.result.adds_received + 1; + let v1 = Maybe.unsafe_get mv in + StableMap.replace t.left_entries k1 v1; + process_left_entry t k1 v1) + else ( + t.result.removes_received <- t.result.removes_received + 1; + remove_left_entry t k1) + +(* Reprocess a left entry when its right key changed *) +let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = + let mb = StableMap.find_maybe t.left_entries k1 in + if Maybe.is_some mb then process_left_entry t k1 (Maybe.unsafe_get mb) + +(* Single-pass process + count for right scratch *) +let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 mv = + let mv = Maybe.of_stable mv in + t.result.entries_received <- t.result.entries_received + 1; + if Maybe.is_some mv then t.result.adds_received <- t.result.adds_received + 1 + else t.result.removes_received <- t.result.removes_received + 1; + StableMapSet.iter_inner_with t.right_key_to_left_keys k2 t + reprocess_left_entry + +let count_output_entry (r : process_result) _k mv = + let mv = Maybe.of_stable mv in + if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 + else r.removes_emitted <- r.removes_emitted + 1 + +let process (t : (_, _, _, _, _, _) t) = + let r = t.result in + r.entries_received <- 0; + r.adds_received <- 0; + r.removes_received <- 0; + r.adds_emitted <- 0; + r.removes_emitted <- 0; + + StableSet.clear t.affected; + StableWave.clear t.output_wave; + + StableMap.iter_with process_left_scratch_entry t t.left_scratch; + StableMap.iter_with process_right_scratch_entry t t.right_scratch; + + StableMap.clear t.left_scratch; + StableMap.clear t.right_scratch; + + StableSet.iter_with recompute_target t t.affected; + + let num_entries = StableWave.count t.output_wave in + r.entries_emitted <- num_entries; + if num_entries > 0 then + StableWave.iter_with t.output_wave count_output_entry r; + r + +let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = + StableMap.replace t.left_entries k1 v1; + let k2 = t.key_of k1 v1 in + StableMap.replace t.left_to_right_key k1 k2; + StableMapSet.add t.right_key_to_left_keys k2 k1; + let right_val = t.right_get k2 in + t.current_k1 <- Maybe.some k1; + StableWave.clear t.emit_wave; + t.f k1 v1 right_val t.emit_wave; + StableWave.iter_with t.emit_wave record_contribution_init t + +let iter_target f t = StableMap.iter f t.target + +let find_target t k = StableMap.find_maybe t.target k + +let target_length t = StableMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli new file mode 100644 index 0000000000..33a465da35 --- /dev/null +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -0,0 +1,66 @@ +(** Zero-allocation (steady-state) join state and processing logic. + + This module is used by {!Reactive.Join.create}. *) + +type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t + +type process_result = { + mutable entries_received: int; + mutable adds_received: int; + mutable removes_received: int; + mutable entries_emitted: int; + mutable adds_emitted: int; + mutable removes_emitted: int; +} + +val create : + key_of:('k1 Stable.t -> 'v1 Stable.t -> 'k2 Stable.t) -> + f: + ('k1 Stable.t -> + 'v1 Stable.t -> + 'v2 Stable.t Maybe.t -> + ('k3, 'v3) StableWave.t -> + unit) -> + merge:('v3 Stable.t -> 'v3 Stable.t -> 'v3 Stable.t) -> + right_get:('k2 Stable.t -> 'v2 Stable.t Maybe.t) -> + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t + +val destroy : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit +(** Release join-owned stable storage. The state must not be used + afterwards. *) + +val output_wave : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> ('k3, 'v3 Maybe.t) StableWave.t +(** The owned output wave populated by [process]. *) + +val push_left : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> + 'k1 Stable.t -> + 'v1 Maybe.t Stable.t -> + unit +(** Push an entry into the left scratch table. *) + +val push_right : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> + 'k2 Stable.t -> + 'v2 Maybe.t Stable.t -> + unit +(** Push an entry into the right scratch table. *) + +val process : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> process_result +(** Process accumulated scratch entries, update target, populate output wave. + Returns stats for the caller to apply. The output wave is populated + (and can be sent to subscribers) only when [entries_emitted > 0]. *) + +val init_entry : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k1 Stable.t -> 'v1 Stable.t -> unit +(** Initialize from an existing left source entry (during setup). *) + +val iter_target : + ('k3 Stable.t -> 'v3 Stable.t -> unit) -> + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> + unit + +val find_target : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k3 Stable.t -> 'v3 Stable.t Maybe.t +val target_length : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> int diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml new file mode 100644 index 0000000000..539a9c2600 --- /dev/null +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -0,0 +1,150 @@ +(** Zero-allocation union state and processing logic. *) + +type ('k, 'v) t = { + merge: 'v Stable.t -> 'v Stable.t -> 'v Stable.t; + left_values: ('k, 'v) StableMap.t; + right_values: ('k, 'v) StableMap.t; + target: ('k, 'v) StableMap.t; + left_scratch: ('k, 'v Maybe.t) StableMap.t; + right_scratch: ('k, 'v Maybe.t) StableMap.t; + affected: 'k StableSet.t; + output_wave: ('k, 'v Maybe.t) StableWave.t; + result: process_result; +} + +and process_result = { + mutable entries_received: int; + mutable adds_received: int; + mutable removes_received: int; + mutable entries_emitted: int; + mutable adds_emitted: int; + mutable removes_emitted: int; +} + +let create ~merge = + { + merge; + left_values = StableMap.create (); + right_values = StableMap.create (); + target = StableMap.create (); + left_scratch = StableMap.create (); + right_scratch = StableMap.create (); + affected = StableSet.create (); + output_wave = StableWave.create (); + result = + { + entries_received = 0; + adds_received = 0; + removes_received = 0; + entries_emitted = 0; + adds_emitted = 0; + removes_emitted = 0; + }; + } + +let destroy t = + StableMap.destroy t.left_values; + StableMap.destroy t.right_values; + StableMap.destroy t.target; + StableMap.destroy t.left_scratch; + StableMap.destroy t.right_scratch; + StableSet.destroy t.affected; + StableWave.destroy t.output_wave + +let output_wave t = t.output_wave + +let push_left t k mv = StableMap.replace t.left_scratch k mv + +let push_right t k mv = StableMap.replace t.right_scratch k mv + +(* Module-level helpers for iter_with — avoid closure allocation *) + +let apply_left_entry t k mv = + let mv = Maybe.of_stable mv in + let r = t.result in + r.entries_received <- r.entries_received + 1; + if Maybe.is_some mv then ( + StableMap.replace t.left_values k (Maybe.unsafe_get mv); + r.adds_received <- r.adds_received + 1) + else ( + StableMap.remove t.left_values k; + r.removes_received <- r.removes_received + 1); + StableSet.add t.affected k + +let apply_right_entry t k mv = + let mv = Maybe.of_stable mv in + let r = t.result in + r.entries_received <- r.entries_received + 1; + if Maybe.is_some mv then ( + StableMap.replace t.right_values k (Maybe.unsafe_get mv); + r.adds_received <- r.adds_received + 1) + else ( + StableMap.remove t.right_values k; + r.removes_received <- r.removes_received + 1); + StableSet.add t.affected k + +let recompute_affected_entry t k = + let r = t.result in + let lv = StableMap.find_maybe t.left_values k in + let rv = StableMap.find_maybe t.right_values k in + let has_left = Maybe.is_some lv in + let has_right = Maybe.is_some rv in + if has_left then ( + if has_right then ( + let merged = t.merge (Maybe.unsafe_get lv) (Maybe.unsafe_get rv) in + StableMap.replace t.target k merged; + StableWave.push t.output_wave k (Maybe.to_stable (Maybe.some merged))) + else + let v = Maybe.unsafe_get lv in + StableMap.replace t.target k v; + StableWave.push t.output_wave k (Maybe.to_stable (Maybe.some v))) + else if has_right then ( + let v = Maybe.unsafe_get rv in + StableMap.replace t.target k v; + StableWave.push t.output_wave k (Maybe.to_stable (Maybe.some v))) + else ( + StableMap.remove t.target k; + StableWave.push t.output_wave k Maybe.none_stable); + r.entries_emitted <- r.entries_emitted + 1; + if has_left || has_right then r.adds_emitted <- r.adds_emitted + 1 + else r.removes_emitted <- r.removes_emitted + 1 + +let process t = + StableSet.clear t.affected; + let r = t.result in + r.entries_received <- 0; + r.adds_received <- 0; + r.removes_received <- 0; + r.entries_emitted <- 0; + r.adds_emitted <- 0; + r.removes_emitted <- 0; + + StableMap.iter_with apply_left_entry t t.left_scratch; + StableMap.iter_with apply_right_entry t t.right_scratch; + + StableMap.clear t.left_scratch; + StableMap.clear t.right_scratch; + + if StableSet.cardinal t.affected > 0 then ( + StableWave.clear t.output_wave; + StableSet.iter_with recompute_affected_entry t t.affected); + + r + +let init_left t k v = + StableMap.replace t.left_values k v; + StableMap.replace t.target k v + +let init_right t k v = + StableMap.replace t.right_values k v; + let lv = StableMap.find_maybe t.left_values k in + let merged = + if Maybe.is_some lv then t.merge (Maybe.unsafe_get lv) v else v + in + StableMap.replace t.target k merged + +let iter_target f t = StableMap.iter f t.target + +let find_target t k = StableMap.find_maybe t.target k + +let target_length t = StableMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli new file mode 100644 index 0000000000..131c4db6c2 --- /dev/null +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -0,0 +1,45 @@ +(** Zero-allocation union state and processing logic. + + This is a private module used by {!Reactive.Union.create}. *) + +type ('k, 'v) t + +type process_result = { + mutable entries_received: int; + mutable adds_received: int; + mutable removes_received: int; + mutable entries_emitted: int; + mutable adds_emitted: int; + mutable removes_emitted: int; +} + +val create : merge:('v Stable.t -> 'v Stable.t -> 'v Stable.t) -> ('k, 'v) t +(** Create union state with the given merge function and an owned output wave. *) + +val destroy : ('k, 'v) t -> unit +(** Release union-owned stable storage. The state must not be used + afterwards. *) + +val output_wave : ('k, 'v) t -> ('k, 'v Maybe.t) StableWave.t +(** The owned output wave populated by [process]. *) + +val push_left : ('k, 'v) t -> 'k Stable.t -> 'v Maybe.t Stable.t -> unit +(** Push an entry into the left scratch table. *) + +val push_right : ('k, 'v) t -> 'k Stable.t -> 'v Maybe.t Stable.t -> unit +(** Push an entry into the right scratch table. *) + +val process : ('k, 'v) t -> process_result +(** Process accumulated scratch entries, update target, populate output wave. + Returns stats for the caller to apply. The output wave is populated + (and can be sent to subscribers) only when [entries_emitted > 0]. *) + +val init_left : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit +(** Initialize a left entry (during setup, before subscriptions). *) + +val init_right : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit +(** Initialize a right entry (during setup, after left). *) + +val iter_target : ('k Stable.t -> 'v Stable.t -> unit) -> ('k, 'v) t -> unit +val find_target : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t Maybe.t +val target_length : ('k, 'v) t -> int diff --git a/analysis/reactive/src/Stable.ml b/analysis/reactive/src/Stable.ml new file mode 100644 index 0000000000..d9316e81fd --- /dev/null +++ b/analysis/reactive/src/Stable.ml @@ -0,0 +1,14 @@ +type 'a t = 'a + +external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" +[@@noalloc] + +let unsafe_of_value x = x +let to_linear_value x = x +let unsafe_to_nonlinear_value x = x +let int x = unsafe_of_value x +let unit = unsafe_of_value () + +let of_value x = + if is_in_minor_heap x then invalid_arg "Stable.of_value"; + unsafe_of_value x diff --git a/analysis/reactive/src/Stable.mli b/analysis/reactive/src/Stable.mli new file mode 100644 index 0000000000..991260eab3 --- /dev/null +++ b/analysis/reactive/src/Stable.mli @@ -0,0 +1,54 @@ +(** Values marked for storage in stable (C-allocated) containers. + + Stable containers live outside the OCaml GC heap. This means the GC will + not trace or move their contents. Two consequences: + + {b Storing values.} Only values that are {e not} in the minor heap may be + stored. Use [of_value] (checked) or [unsafe_of_value] (unchecked) to mark + a value before storing it. [unsafe_of_value] is the only truly unsafe + operation: if a minor-heap value is stored, the GC may relocate the + original and the stable container will hold a dangling pointer. + + {b Reading values.} Use [to_linear_value] to read a value back. The + result is an ordinary OCaml value that is {e not} protected by the GC + (the stable container owns the only reference). The caller must consume + it immediately and not stash it in a long-lived OCaml data structure, + because the stable container may destroy or overwrite its slot at any + time. Short-lived uses (comparison, passing to a function, computing a + result) are fine. + + {b Stable-safety.} A module is {e stable-safe} when it contains zero calls + to [unsafe_of_value] — all stored values are known stable by construction. + See [STABLE_SAFETY.md] in the reactive directory for a guide on how to + establish stable-safety and repair violations. *) + +type 'a t + +val unsafe_of_value : 'a -> 'a t +(** Unsafely mark a value as suitable for stable storage. The caller must + ensure the value is not in the minor heap. + This is the only truly unsafe operation in the module. *) + +val of_value : 'a -> 'a t +(** Safely mark a value as suitable for stable storage. + + Raises [Invalid_argument] if the value is currently in the minor heap. + Immediates are accepted. *) + +val int : int -> int t +(** Safely mark an [int] as suitable for stable storage. *) + +val unit : unit t +(** [()] as a stable value. *) + +val to_linear_value : 'a t -> 'a +(** Read a value from a stable container. The result must be consumed + immediately (linear use) and not stored in long-lived OCaml structures, + as the stable container may destroy or overwrite the slot at any time. *) + +val unsafe_to_nonlinear_value : 'a t -> 'a +(** Like [to_linear_value] but explicitly marks a non-linear use: the + returned value will be stored in a long-lived OCaml structure (e.g., + a hashtable or accumulator list). This is safe only when the stable + container will not destroy or overwrite the slot while the OCaml + reference is alive. Each call site should be audited individually. *) diff --git a/analysis/reactive/src/StableList.ml b/analysis/reactive/src/StableList.ml new file mode 100644 index 0000000000..a7570d732d --- /dev/null +++ b/analysis/reactive/src/StableList.ml @@ -0,0 +1,32 @@ +type 'a t = 'a Stable.t list + +(* Zero-cost reinterpretation: Stable.t is identity at runtime, + so 'a list and 'a Stable.t list have the same representation. *) +external reinterpret : 'a list -> 'a Stable.t list = "%identity" + +let unsafe_of_list (l : 'a list) : 'a t = reinterpret l + +let of_list (l : 'a list) : 'a t = + ignore (Stable.of_value l); + reinterpret l + +let to_stable (l : 'a t) : 'a t Stable.t = Stable.unsafe_of_value l + +let maybe_to_stable (m : 'a t Maybe.t) : 'a t Maybe.t Stable.t = + Stable.unsafe_of_value m + +let empty () : 'a t = [] +let is_empty xs = xs = [] +let length = List.length +let iter = List.iter +let exists = List.exists + +let rec iter_with f arg = function + | [] -> () + | x :: rest -> + f arg x; + iter_with f arg rest + +let rec exists_with f arg = function + | [] -> false + | x :: rest -> f arg x || exists_with f arg rest diff --git a/analysis/reactive/src/StableList.mli b/analysis/reactive/src/StableList.mli new file mode 100644 index 0000000000..a7c0752444 --- /dev/null +++ b/analysis/reactive/src/StableList.mli @@ -0,0 +1,28 @@ +(** Lists intended for storage in stable (C-allocated) containers. + + The list cells are ordinary OCaml heap values. The container that + stores a [StableList.t] is responsible for the [Stable.t] wrapping. *) + +type 'a t + +val unsafe_of_list : 'a list -> 'a t +(** Reinterpret a list as a [StableList.t] without checking. *) + +val of_list : 'a list -> 'a t +(** Checked version of [unsafe_of_list]. Raises if the list is still in the + minor heap. *) + +val to_stable : 'a t -> 'a t Stable.t +(** Safe conversion: a [StableList.t] is always in the major heap by + construction, so wrapping it in [Stable.t] is safe. *) + +val maybe_to_stable : 'a t Maybe.t -> 'a t Maybe.t Stable.t +(** Safe conversion for a [Maybe.t] containing a [StableList.t]. *) + +val empty : unit -> 'a t +val is_empty : 'a t -> bool +val length : 'a t -> int +val iter : ('a Stable.t -> unit) -> 'a t -> unit +val iter_with : ('b -> 'a Stable.t -> unit) -> 'b -> 'a t -> unit +val exists : ('a Stable.t -> bool) -> 'a t -> bool +val exists_with : ('b -> 'a Stable.t -> bool) -> 'b -> 'a t -> bool diff --git a/analysis/reactive/src/StableMap.ml b/analysis/reactive/src/StableMap.ml new file mode 100644 index 0000000000..945019acce --- /dev/null +++ b/analysis/reactive/src/StableMap.ml @@ -0,0 +1,182 @@ +type ('k, 'v) t = (Obj.t, int, int) Allocator.Block2.t + +let initial_capacity = 8 +let max_load_percent = 82 + +let empty_sentinel : Obj.t = Obj.repr (Array.make 257 0) +let tomb_sentinel : Obj.t = Obj.repr (Array.make 257 0) + +let[@inline] empty_slot () : 'a Stable.t = Obj.magic empty_sentinel +let[@inline] tomb_slot () : 'a Stable.t = Obj.magic tomb_sentinel + +let[@inline] pair_capacity t = Allocator.Block2.capacity t / 2 +let population = Allocator.Block2.get0 +let set_population = Allocator.Block2.set0 +let occupation = Allocator.Block2.get1 +let set_occupation = Allocator.Block2.set1 +let[@inline] mask t = pair_capacity t - 1 + +let[@inline] key_slot j = 2 * j +let[@inline] val_slot j = (2 * j) + 1 + +let[@inline] get_key t j : 'k Stable.t = + Obj.magic (Allocator.Block2.get t (key_slot j)) + +let[@inline] set_key t j (k : 'k Stable.t) = + Allocator.Block2.set t (key_slot j) (Obj.magic k) + +let[@inline] get_val t j : 'v Stable.t = + Obj.magic (Allocator.Block2.get t (val_slot j)) + +let[@inline] set_val t j (v : 'v Stable.t) = + Allocator.Block2.set t (val_slot j) (Obj.magic v) + +let[@inline] start t x = Hashtbl.hash (Stable.to_linear_value x) land mask t +let[@inline] next t j = (j + 1) land mask t +let[@inline] crowded_or_full occ cap = 100 * occ > max_load_percent * cap + +let clear_keys t = + for i = 0 to pair_capacity t - 1 do + set_key t i (empty_slot ()) + done + +let create () = + let t = + Allocator.Block2.create ~capacity:(2 * initial_capacity) ~x0:0 ~y0:0 + in + clear_keys t; + t + +let destroy = Allocator.Block2.destroy + +let clear t = + set_population t 0; + set_occupation t 0; + clear_keys t + +let insert_absent t k v = + let empty : 'k Stable.t = empty_slot () in + let j = ref (start t k) in + while get_key t !j != empty do + j := next t !j + done; + set_key t !j k; + set_val t !j v + +let resize t new_cap = + let old_cap = pair_capacity t in + let old = Allocator.Block2.create ~capacity:(2 * old_cap) ~x0:0 ~y0:0 in + Allocator.Block2.blit ~src:t ~src_pos:0 ~dst:old ~dst_pos:0 ~len:(2 * old_cap); + Allocator.Block2.resize t ~capacity:(2 * new_cap); + set_population t 0; + set_occupation t 0; + clear_keys t; + for i = 0 to old_cap - 1 do + let k = get_key old i in + if k != empty_slot () && k != tomb_slot () then ( + insert_absent t k (get_val old i); + set_population t (population t + 1); + set_occupation t (occupation t + 1)) + done; + Allocator.Block2.destroy old + +let maybe_grow_before_insert t = + let cap = pair_capacity t in + let next_occupation = occupation t + 1 in + if crowded_or_full next_occupation cap then resize t (2 * cap) + +let replace t k v = + maybe_grow_before_insert t; + let empty : 'k Stable.t = empty_slot () in + let tomb : 'k Stable.t = tomb_slot () in + let j = ref (start t k) in + let first_tomb = ref (-1) in + let done_ = ref false in + while not !done_ do + let current = get_key t !j in + if current == empty then ( + let dst = if !first_tomb >= 0 then !first_tomb else !j in + if !first_tomb < 0 then set_occupation t (occupation t + 1); + set_population t (population t + 1); + set_key t dst k; + set_val t dst v; + done_ := true) + else if current == tomb then ( + if !first_tomb < 0 then first_tomb := !j; + j := next t !j) + else if current = k then ( + set_val t !j v; + done_ := true) + else j := next t !j + done + +let remove t k = + let empty : 'k Stable.t = empty_slot () in + let tomb : 'k Stable.t = tomb_slot () in + let j = ref (start t k) in + let done_ = ref false in + while not !done_ do + let current = get_key t !j in + if current == empty then done_ := true + else if current == tomb then j := next t !j + else if current = k then ( + set_key t !j tomb; + set_population t (population t - 1); + done_ := true) + else j := next t !j + done + +let mem t k = + let empty : 'k Stable.t = empty_slot () in + let tomb : 'k Stable.t = tomb_slot () in + let j = ref (start t k) in + let found = ref false in + let done_ = ref false in + while not !done_ do + let current = get_key t !j in + if current == empty then done_ := true + else if current == tomb then j := next t !j + else if current = k then ( + found := true; + done_ := true) + else j := next t !j + done; + !found + +let find_maybe t k = + let empty : 'k Stable.t = empty_slot () in + let tomb : 'k Stable.t = tomb_slot () in + let j = ref (start t k) in + let found = ref Maybe.none in + let done_ = ref false in + while not !done_ do + let current = get_key t !j in + if current == empty then done_ := true + else if current == tomb then j := next t !j + else if current = k then ( + found := Maybe.some (get_val t !j); + done_ := true) + else j := next t !j + done; + !found + +let iter_with f arg t = + let empty : 'k Stable.t = empty_slot () in + let tomb : 'k Stable.t = tomb_slot () in + if population t > 0 then + for i = 0 to pair_capacity t - 1 do + let k = get_key t i in + if k != empty && k != tomb then f arg k (get_val t i) + done + +let iter_with2 f arg1 arg2 t = + let empty : 'k Stable.t = empty_slot () in + let tomb : 'k Stable.t = tomb_slot () in + if population t > 0 then + for i = 0 to pair_capacity t - 1 do + let k = get_key t i in + if k != empty && k != tomb then f arg1 arg2 k (get_val t i) + done + +let iter f t = iter_with (fun f k v -> f k v) f t +let cardinal = population diff --git a/analysis/reactive/src/StableMap.mli b/analysis/reactive/src/StableMap.mli new file mode 100644 index 0000000000..6227aaca49 --- /dev/null +++ b/analysis/reactive/src/StableMap.mli @@ -0,0 +1,29 @@ +(** Stable mutable maps for reactive internals. *) + +type ('k, 'v) t + +val create : unit -> ('k, 'v) t +val destroy : ('k, 'v) t -> unit +val clear : ('k, 'v) t -> unit + +val replace : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit + +val remove : ('k, 'v) t -> 'k Stable.t -> unit + +val mem : ('k, 'v) t -> 'k Stable.t -> bool + +val find_maybe : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t Maybe.t + +val iter_with : + ('a -> 'k Stable.t -> 'v Stable.t -> unit) -> 'a -> ('k, 'v) t -> unit + +val iter_with2 : + ('a -> 'b -> 'k Stable.t -> 'v Stable.t -> unit) -> + 'a -> + 'b -> + ('k, 'v) t -> + unit + +val iter : ('k Stable.t -> 'v Stable.t -> unit) -> ('k, 'v) t -> unit + +val cardinal : ('k, 'v) t -> int diff --git a/analysis/reactive/src/StableMapMap.ml b/analysis/reactive/src/StableMapMap.ml new file mode 100644 index 0000000000..ad118a8894 --- /dev/null +++ b/analysis/reactive/src/StableMapMap.ml @@ -0,0 +1,64 @@ +(** A map from outer keys to inner maps, backed by stable storage. + + Each outer key owns its inner map. When an outer binding is removed, the + inner map is destroyed immediately. *) + +type ('ko, 'ki, 'v) t = ('ko, ('ki, 'v) StableMap.t) StableMap.t + +let create () = StableMap.create () + +let destroy t = + StableMap.iter_with + (fun () _ko inner -> StableMap.destroy (Stable.to_linear_value inner)) + () t; + StableMap.destroy t + +let ensure_inner t ko = + let m = StableMap.find_maybe t ko in + if Maybe.is_some m then Stable.to_linear_value (Maybe.unsafe_get m) + else + let inner = StableMap.create () in + StableMap.replace t ko (Stable.unsafe_of_value inner); + inner + +let replace t ko ki v = + let inner = ensure_inner t ko in + StableMap.replace inner ki v + +let remove_from_inner_and_recycle_if_empty t ko ki = + let mb = StableMap.find_maybe t ko in + if Maybe.is_some mb then ( + let inner = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableMap.remove inner ki; + if StableMap.cardinal inner = 0 then ( + StableMap.remove t ko; + StableMap.destroy inner)) + +let drain_outer t ko ctx f = + let mb = StableMap.find_maybe t ko in + if Maybe.is_some mb then ( + let inner = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableMap.iter_with f ctx inner; + StableMap.remove t ko; + StableMap.destroy inner) + +let find_inner_maybe t ko = + let mb = StableMap.find_maybe t ko in + if Maybe.is_some mb then + Maybe.some (Stable.to_linear_value (Maybe.unsafe_get mb)) + else Maybe.none + +let iter_inner_with t ko ctx f = + let mb = StableMap.find_maybe t ko in + if Maybe.is_some mb then + let inner = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableMap.iter_with f ctx inner + +let inner_cardinal t ko = + let mb = StableMap.find_maybe t ko in + if Maybe.is_some mb then + StableMap.cardinal (Stable.to_linear_value (Maybe.unsafe_get mb)) + else 0 + +let outer_cardinal t = StableMap.cardinal t +let debug_miss_count _t = 0 diff --git a/analysis/reactive/src/StableMapMap.mli b/analysis/reactive/src/StableMapMap.mli new file mode 100644 index 0000000000..9e6a9110cf --- /dev/null +++ b/analysis/reactive/src/StableMapMap.mli @@ -0,0 +1,52 @@ +(** A map from outer keys to inner maps, backed by stable storage. *) + +type ('ko, 'ki, 'v) t + +val create : unit -> ('ko, 'ki, 'v) t +(** [create ()] creates an empty map-of-map. *) + +val destroy : ('ko, 'ki, 'v) t -> unit +(** Destroy the outer map and all owned inner maps. *) + +val replace : + ('ko, 'ki, 'v) t -> 'ko Stable.t -> 'ki Stable.t -> 'v Stable.t -> unit +(** [replace t ko ki v] ensures an inner map for [ko], then sets [ki -> v]. *) + +val remove_from_inner_and_recycle_if_empty : + ('ko, 'ki, 'v) t -> 'ko Stable.t -> 'ki Stable.t -> unit +(** Removes [ki] from [ko]'s inner map. If it becomes empty, removes [ko], + and destroys the inner map. No-op if [ko] is absent. *) + +val drain_outer : + ('ko, 'ki, 'v) t -> + 'ko Stable.t -> + 'a -> + ('a -> 'ki Stable.t -> 'v Stable.t -> unit) -> + unit +(** [drain_outer t ko ctx f] iterates [f ctx ki v] for all entries in [ko]'s + inner map, then removes [ko] and destroys the inner map. + No-op if [ko] is absent. *) + +val find_inner_maybe : + ('ko, 'ki, 'v) t -> 'ko Stable.t -> ('ki, 'v) StableMap.t Maybe.t +(** Zero-allocation lookup of inner map by outer key. + + The returned inner map is owned by the pool-map. It becomes invalid if the + outer binding is later removed, [drain_outer] is called, or the whole + structure is [destroy]ed. *) + +val iter_inner_with : + ('ko, 'ki, 'v) t -> + 'ko Stable.t -> + 'a -> + ('a -> 'ki Stable.t -> 'v Stable.t -> unit) -> + unit +(** [iter_inner_with t ko ctx f] calls [f ctx ki v] for [ko]'s inner map. + No-op if [ko] is absent. *) + +val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko Stable.t -> int +val outer_cardinal : ('ko, 'ki, 'v) t -> int + +val debug_miss_count : ('ko, 'ki, 'v) t -> int +(** Always [0] in the stable-backed implementation. Kept for diagnostics and + allocation-test compatibility. *) diff --git a/analysis/reactive/src/StableMapSet.ml b/analysis/reactive/src/StableMapSet.ml new file mode 100644 index 0000000000..b994b18912 --- /dev/null +++ b/analysis/reactive/src/StableMapSet.ml @@ -0,0 +1,76 @@ +(** A map from keys to sets, backed by stable storage. + + Each outer key owns its inner set. When an outer binding is removed, the + inner set is destroyed immediately. *) + +type ('k, 'v) t = ('k, 'v StableSet.t) StableMap.t + +let create () = StableMap.create () + +let destroy t = + StableMap.iter_with + (fun () _k set -> StableSet.destroy (Stable.to_linear_value set)) + () t; + StableMap.destroy t + +let destroy_inner_set () _k set = StableSet.destroy (Stable.to_linear_value set) + +let ensure t k = + let m = StableMap.find_maybe t k in + if Maybe.is_some m then Stable.to_linear_value (Maybe.unsafe_get m) + else + let set = StableSet.create () in + StableMap.replace t k (Stable.unsafe_of_value set); + set + +let add t k v = + let set = ensure t k in + StableSet.add set v + +let drain_key t k ctx f = + let mb = StableMap.find_maybe t k in + if Maybe.is_some mb then ( + let set = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableSet.iter_with f ctx set; + StableMap.remove t k; + StableSet.destroy set) + +let remove_from_set_and_recycle_if_empty t k v = + let mb = StableMap.find_maybe t k in + if Maybe.is_some mb then ( + let set = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableSet.remove set v; + if StableSet.cardinal set = 0 then ( + StableMap.remove t k; + StableSet.destroy set)) + +let find_inner_maybe t k = + let mb = StableMap.find_maybe t k in + if Maybe.is_some mb then + Maybe.some (Stable.to_linear_value (Maybe.unsafe_get mb)) + else Maybe.none + +let iter_inner_with t k ctx f = + let mb = StableMap.find_maybe t k in + if Maybe.is_some mb then + let set = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableSet.iter_with f ctx set + +let exists_inner_with t k ctx f = + let mb = StableMap.find_maybe t k in + if Maybe.is_some mb then + let set = Stable.to_linear_value (Maybe.unsafe_get mb) in + StableSet.exists_with f ctx set + else false + +let iter_with t ctx f = + StableMap.iter_with + (fun ctx stable_k stable_set -> + f ctx stable_k (Stable.to_linear_value stable_set)) + ctx t + +let clear t = + StableMap.iter_with destroy_inner_set () t; + StableMap.clear t +let cardinal t = StableMap.cardinal t +let debug_miss_count _t = 0 diff --git a/analysis/reactive/src/StableMapSet.mli b/analysis/reactive/src/StableMapSet.mli new file mode 100644 index 0000000000..647353effd --- /dev/null +++ b/analysis/reactive/src/StableMapSet.mli @@ -0,0 +1,56 @@ +(** A map from keys to sets, backed by stable storage. *) + +type ('k, 'v) t + +val create : unit -> ('k, 'v) t +(** [create ()] creates an empty map-of-set. *) + +val destroy : ('k, 'v) t -> unit +(** Destroy the outer map and all owned inner sets. *) + +val add : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit +(** [add t k v] ensures a set exists for [k] and adds [v] to it. *) + +val drain_key : + ('k, 'v) t -> 'k Stable.t -> 'a -> ('a -> 'v Stable.t -> unit) -> unit +(** [drain_key t k ctx f] iterates [f ctx v] over the set for [k], then + removes [k] from the outer map and destroys its inner set. + No-op if [k] is absent. *) + +val remove_from_set_and_recycle_if_empty : + ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit +(** [remove_from_set_and_recycle_if_empty t k v] removes [v] from [k]'s set. + If the set becomes empty, [k] is removed and its inner set destroyed. + No-op if [k] is absent. *) + +val find_inner_maybe : ('k, 'v) t -> 'k Stable.t -> 'v StableSet.t Maybe.t +(** Zero-allocation lookup of the inner set by outer key. + + The returned inner set is owned by the pool-map. It becomes invalid if the + outer binding is later removed, [clear] is called, or the whole structure is + [destroy]ed. Prefer {!iter_inner_with} and {!exists_inner_with} when direct + access is not needed. *) + +val iter_inner_with : + ('k, 'v) t -> 'k Stable.t -> 'a -> ('a -> 'v Stable.t -> unit) -> unit +(** [iter_inner_with t k ctx f] calls [f ctx v] for each element in [k]'s inner + set. No-op if [k] is absent. *) + +val exists_inner_with : + ('k, 'v) t -> 'k Stable.t -> 'a -> ('a -> 'v Stable.t -> bool) -> bool +(** [exists_inner_with t k ctx f] returns [true] if [f ctx v] holds for some + element in [k]'s inner set. Returns [false] if [k] is absent. *) + +val iter_with : + ('k, 'v) t -> 'a -> ('a -> 'k Stable.t -> 'v StableSet.t -> unit) -> unit +(** [iter_with t ctx f] calls [f ctx k set] for each binding. *) + +val clear : ('k, 'v) t -> unit +(** Removes all outer bindings and destroys their inner sets. *) + +val cardinal : ('k, 'v) t -> int +(** Number of live entries in the outer map. *) + +val debug_miss_count : ('k, 'v) t -> int +(** Always [0] in the stable-backed implementation. Kept for diagnostics and + allocation-test compatibility. *) diff --git a/analysis/reactive/src/StableQueue.ml b/analysis/reactive/src/StableQueue.ml new file mode 100644 index 0000000000..0954b70ef3 --- /dev/null +++ b/analysis/reactive/src/StableQueue.ml @@ -0,0 +1,62 @@ +(* Representation of ['a t]: + + - ['a t] is [('a, int, int) Allocator.Block2.t]. + - Header slot [0]: head index. + - Header slot [1]: tail index. + - Data slots: queue elements, stored as ['a Stable.t]. + + Head and tail are monotone counters. Physical slot positions are computed + from the current capacity via bit masking, so the backing capacity always + stays a power of two. *) + +type 'a t = ('a, int, int) Allocator.Block2.t + +let initial_capacity = 16 + +let head = Allocator.Block2.get0 +let set_head = Allocator.Block2.set0 +let tail = Allocator.Block2.get1 +let set_tail = Allocator.Block2.set1 +let slot_capacity = Allocator.Block2.capacity + +let create () = Allocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 + +let destroy = Allocator.Block2.destroy + +let clear t = + set_head t 0; + set_tail t 0 + +let[@inline] is_empty t = head t = tail t +let[@inline] length t = tail t - head t +let[@inline] mask t = slot_capacity t - 1 +let[@inline] slot_index t i = i land mask t + +let resize (type a) (t : a t) new_cap = + let old_len = length t in + let fresh = Allocator.Block2.create ~capacity:new_cap ~x0:0 ~y0:old_len in + for i = 0 to old_len - 1 do + let src = slot_index t (head t + i) in + Allocator.Block2.set fresh i (Allocator.Block2.get t src) + done; + Allocator.Block2.resize t ~capacity:new_cap; + Allocator.Block2.blit ~src:fresh ~src_pos:0 ~dst:t ~dst_pos:0 ~len:new_cap; + set_head t 0; + set_tail t old_len; + Allocator.Block2.destroy fresh + +let maybe_grow_before_push t = + if length t = slot_capacity t then resize t (2 * slot_capacity t) + +let push t x = + maybe_grow_before_push t; + let tail_i = tail t in + Allocator.Block2.set t (slot_index t tail_i) x; + set_tail t (tail_i + 1) + +let pop t = + if is_empty t then invalid_arg "StableQueue.pop: empty"; + let head_i = head t in + let x = Allocator.Block2.get t (slot_index t head_i) in + set_head t (head_i + 1); + x diff --git a/analysis/reactive/src/StableQueue.mli b/analysis/reactive/src/StableQueue.mli new file mode 100644 index 0000000000..ca1037dc58 --- /dev/null +++ b/analysis/reactive/src/StableQueue.mli @@ -0,0 +1,24 @@ +(** Stable FIFO queues for reactive internals. *) + +type 'a t + +val create : unit -> 'a t +(** Create an empty FIFO queue. *) + +val destroy : 'a t -> unit +(** Release the queue's owned stable storage. The queue must not be used + afterwards. *) + +val clear : 'a t -> unit +(** Remove all elements while keeping the current storage. *) + +val push : 'a t -> 'a Stable.t -> unit +(** Add an element at the tail of the queue. *) + +val is_empty : 'a t -> bool +(** Whether the queue currently holds no elements. *) + +val pop : 'a t -> 'a Stable.t +(** Remove and return the next element. + + @raise Invalid_argument if the queue is empty. *) diff --git a/analysis/reactive/src/StableSet.ml b/analysis/reactive/src/StableSet.ml new file mode 100644 index 0000000000..f9df875071 --- /dev/null +++ b/analysis/reactive/src/StableSet.ml @@ -0,0 +1,184 @@ +(* Representation of ['a t]: + + - ['a t] is [('a, int, int) Allocator.Block2.t]. + - Header slot [0]: population, exposed as [int]. + - Header slot [1]: index mask, exposed as [int]. + - Data slots: keys, stored as ['a Stable.t]. + + The backing block lives stable. Elements are ordinary OCaml values whose + storage invariant has already been established before insertion. + + Data slots contain either: + - the distinguished empty sentinel, meaning the slot has never been used + - the distinguished tomb sentinel, meaning the slot was removed + - a real set element. *) + +type 'a t = ('a, int, int) Allocator.Block2.t + +let initial_capacity = 8 +let max_load_percent = 82 + +let sentinel : Obj.t = Obj.repr (Array.make 257 0) +let tomb : Obj.t = Obj.repr (Array.make 257 0) +let[@inline] empty_sentinel = fun () -> (Obj.magic sentinel : 'a Stable.t) +let[@inline] tomb_sentinel = fun () -> (Obj.magic tomb : 'a Stable.t) + +let slot_capacity = Allocator.Block2.capacity +let population = Allocator.Block2.get0 +let set_population = Allocator.Block2.set0 +let mask = Allocator.Block2.get1 +let set_mask = Allocator.Block2.set1 + +let[@inline] start t x = Hashtbl.hash (Stable.to_linear_value x) land mask t +let[@inline] next t j = (j + 1) land mask t + +let[@inline] crowded_or_full pop cap = 100 * pop > max_load_percent * cap + +let clear_slots t = + for i = 0 to slot_capacity t - 1 do + Allocator.Block2.set t i (empty_sentinel ()) + done + +let create () = + let t = + Allocator.Block2.create ~capacity:initial_capacity ~x0:0 + ~y0:(initial_capacity - 1) + in + clear_slots t; + t + +let destroy = Allocator.Block2.destroy + +let clear t = + set_population t 0; + clear_slots t + +let add_absent_key (type a) (t : a t) (x : a Stable.t) = + let j = ref (start t x) in + while + let current = Allocator.Block2.get t !j in + current != empty_sentinel () && current != tomb_sentinel () + do + j := next t !j + done; + Allocator.Block2.set t !j x + +let resize (type a) (t : a t) new_cap = + let old_cap = slot_capacity t in + let old_keys : a t = + Allocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:(old_cap - 1) + in + Allocator.Block2.blit ~src:t ~src_pos:0 ~dst:old_keys ~dst_pos:0 ~len:old_cap; + Allocator.Block2.resize t ~capacity:new_cap; + clear_slots t; + set_mask t (new_cap - 1); + for i = 0 to old_cap - 1 do + let x = Allocator.Block2.get old_keys i in + if x != empty_sentinel () && x != tomb_sentinel () then add_absent_key t x + done; + Allocator.Block2.destroy old_keys + +let maybe_grow_before_add (type a) (t : a t) = + let cap = slot_capacity t in + let next_population = population t + 1 in + if crowded_or_full next_population cap then resize t (2 * cap) + +let add (type a) (t : a t) (x : a Stable.t) = + maybe_grow_before_add t; + let j = ref (start t x) in + let first_tomb = ref (-1) in + let found = ref false in + while not !found do + let current = Allocator.Block2.get t !j in + if current == empty_sentinel () then ( + let dst = if !first_tomb >= 0 then !first_tomb else !j in + Allocator.Block2.set t dst x; + set_population t (population t + 1); + found := true) + else if current == tomb_sentinel () then ( + if !first_tomb < 0 then first_tomb := !j; + j := next t !j) + else if current = x then found := true + else j := next t !j + done + +let remove (type a) (t : a t) (x : a Stable.t) = + let j = ref (start t x) in + let done_ = ref false in + while not !done_ do + let current = Allocator.Block2.get t !j in + if current == empty_sentinel () then done_ := true + else if current == tomb_sentinel () then j := next t !j + else if current = x then ( + Allocator.Block2.set t !j (tomb_sentinel ()); + set_population t (population t - 1); + done_ := true) + else j := next t !j + done + +let mem (type a) (t : a t) (x : a Stable.t) = + let j = ref (start t x) in + let found = ref false in + let done_ = ref false in + while not !done_ do + let current = Allocator.Block2.get t !j in + if current == empty_sentinel () then done_ := true + else if current == tomb_sentinel () then j := next t !j + else if current = x then ( + found := true; + done_ := true) + else j := next t !j + done; + !found + +let iter_with (type a k) (f : a -> k Stable.t -> unit) (arg : a) (t : k t) = + if population t > 0 then + for i = 0 to slot_capacity t - 1 do + let x = Allocator.Block2.get t i in + if x != empty_sentinel () && x != tomb_sentinel () then f arg x + done + +let iter_with2 (type a b k) (f : a -> b -> k Stable.t -> unit) (arg1 : a) + (arg2 : b) (t : k t) = + if population t > 0 then + for i = 0 to slot_capacity t - 1 do + let x = Allocator.Block2.get t i in + if x != empty_sentinel () && x != tomb_sentinel () then f arg1 arg2 x + done + +let exists_with (type a k) (f : a -> k Stable.t -> bool) (arg : a) (t : k t) = + let found = ref false in + let done_ = ref false in + let i = ref 0 in + while (not !done_) && !i < slot_capacity t do + let x = Allocator.Block2.get t !i in + if x != empty_sentinel () && x != tomb_sentinel () && f arg x then ( + found := true; + done_ := true); + incr i + done; + !found + +let equal (type a) (a : a t) (b : a t) = + population a = population b + && + let ok = ref true in + let i = ref 0 in + let cap = slot_capacity a in + while !ok && !i < cap do + let x = Allocator.Block2.get a !i in + if x != empty_sentinel () && x != tomb_sentinel () && not (mem b x) then + ok := false; + incr i + done; + !ok + +let copy ~dst src = + clear dst; + if population src > 0 then + for i = 0 to slot_capacity src - 1 do + let x = Allocator.Block2.get src i in + if x != empty_sentinel () && x != tomb_sentinel () then add dst x + done + +let cardinal = population diff --git a/analysis/reactive/src/StableSet.mli b/analysis/reactive/src/StableSet.mli new file mode 100644 index 0000000000..8053022e67 --- /dev/null +++ b/analysis/reactive/src/StableSet.mli @@ -0,0 +1,43 @@ +(** Stable mutable sets for reactive internals. + + Elements are ordinary OCaml values. The set's backing storage lives in the + custom allocator via {!Allocator.Block2}. *) + +type 'a t + +val create : unit -> 'a t +(** Create an empty set. *) + +val destroy : 'a t -> unit +(** Release the set's owned stable storage. The set must not be used + afterwards. *) + +val clear : 'a t -> unit +(** Remove all elements while keeping the current storage. *) + +val add : 'a t -> 'a Stable.t -> unit +(** Add an element to the set. Re-adding an existing element is a no-op. *) + +val remove : 'a t -> 'a Stable.t -> unit +(** Remove an element from the set. Removing a missing element is a no-op. *) + +val mem : 'a t -> 'a Stable.t -> bool +(** Test whether the set contains an element. *) + +val iter_with : ('b -> 'a Stable.t -> unit) -> 'b -> 'a t -> unit +(** [iter_with f arg t] calls [f arg x] for each element. *) + +val iter_with2 : ('b -> 'c -> 'a Stable.t -> unit) -> 'b -> 'c -> 'a t -> unit +(** [iter_with2 f arg1 arg2 t] calls [f arg1 arg2 x] for each element. *) + +val exists_with : ('b -> 'a Stable.t -> bool) -> 'b -> 'a t -> bool +(** [exists_with f arg t] returns [true] if [f arg x] holds for some element. *) + +val equal : 'a t -> 'a t -> bool +(** [equal a b] returns [true] if both sets contain the same elements. *) + +val copy : dst:'a t -> 'a t -> unit +(** [copy ~dst src] clears [dst] then adds all elements of [src] to it. *) + +val cardinal : 'a t -> int +(** Number of elements currently stored. *) diff --git a/analysis/reactive/src/StableWave.ml b/analysis/reactive/src/StableWave.ml new file mode 100644 index 0000000000..40042d3585 --- /dev/null +++ b/analysis/reactive/src/StableWave.ml @@ -0,0 +1,58 @@ +type ('k, 'v) t = (Obj.t, int, int) Allocator.Block2.t + +let entry_width = 2 + +let length (t : ('k, 'v) t) : int = Allocator.Block2.get0 t + +let set_length (t : ('k, 'v) t) len = Allocator.Block2.set0 t len + +let create ?(max_entries = 16) () : ('k, 'v) t = + if max_entries < 0 then + invalid_arg "ReactiveWave.create: max_entries must be >= 0"; + let t = + Allocator.Block2.create ~capacity:(max_entries * entry_width) ~x0:0 ~y0:0 + in + set_length t 0; + t + +let clear (t : ('k, 'v) t) = set_length t 0 + +let destroy (t : ('k, 'v) t) = Allocator.Block2.destroy t + +let ensure_capacity (t : ('k, 'v) t) needed = + let current = Allocator.Block2.capacity t / entry_width in + if needed > current then ( + let next = ref (max 1 current) in + while !next < needed do + next := !next * 2 + done; + Allocator.Block2.resize t ~capacity:(!next * entry_width)) + +let push (type k v) (t : (k, v) t) (k : k Stable.t) (v : v Stable.t) = + let len = length t in + ensure_capacity t (len + 1); + let key_slot = len * entry_width in + Allocator.Block2.set t key_slot (Obj.magic k); + Allocator.Block2.set t (key_slot + 1) (Obj.magic v); + set_length t (len + 1) + +let iter (type k v) (t : (k, v) t) (f : k Stable.t -> v Stable.t -> unit) = + let len = length t in + for i = 0 to len - 1 do + let key_slot = i * entry_width in + f + (Obj.magic (Allocator.Block2.get t key_slot)) + (Obj.magic (Allocator.Block2.get t (key_slot + 1))) + done + +let iter_with (type a k v) (t : (k, v) t) + (f : a -> k Stable.t -> v Stable.t -> unit) (arg : a) = + let len = length t in + for i = 0 to len - 1 do + let key_slot = i * entry_width in + f arg + (Obj.magic (Allocator.Block2.get t key_slot)) + (Obj.magic (Allocator.Block2.get t (key_slot + 1))) + done + +let count (t : ('k, 'v) t) = length t diff --git a/analysis/reactive/src/StableWave.mli b/analysis/reactive/src/StableWave.mli new file mode 100644 index 0000000000..3eaa6cb973 --- /dev/null +++ b/analysis/reactive/src/StableWave.mli @@ -0,0 +1,31 @@ +(** A wave is a growable batch of key/value entries stored in stable + allocator-backed storage. Its API is marked with + [Stable.t] so call sites make the boundary explicit. + Current callers mostly use the unsafe conversions; those call sites are the + audit surface for later enforcing the invariant. *) + +type ('k, 'v) t + +val create : ?max_entries:int -> unit -> ('k, 'v) t +(** Create an empty wave with an optional initial capacity hint. The wave + grows automatically if that capacity is exceeded. *) + +val clear : ('k, 'v) t -> unit +(** Remove all entries from the wave without releasing its storage. *) + +val destroy : ('k, 'v) t -> unit +(** Release the wave's stable storage. The wave must not be used after this. *) + +val push : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit +(** Append one stable-marked entry to the wave. Callers are currently + responsible for establishing the stable invariant before calling. *) + +val iter : ('k, 'v) t -> ('k Stable.t -> 'v Stable.t -> unit) -> unit + +val iter_with : + ('k, 'v) t -> ('a -> 'k Stable.t -> 'v Stable.t -> unit) -> 'a -> unit +(** [iter_with t f arg] calls [f arg k v] for each entry. + Unlike [iter t (f arg)], avoids allocating a closure when [f] + is a top-level function. Prefer this on hot paths. *) + +val count : ('k, 'v) t -> int diff --git a/analysis/reactive/src/dune b/analysis/reactive/src/dune index cc8d382ccd..d268114721 100644 --- a/analysis/reactive/src/dune +++ b/analysis/reactive/src/dune @@ -1,5 +1,8 @@ (library (name reactive) (wrapped false) - (private_modules ReactiveFixpoint) + (private_modules StableQueue) + (foreign_stubs + (language c) + (names reactive_allocator_stubs)) (libraries unix)) diff --git a/analysis/reactive/src/reactive_allocator_stubs.c b/analysis/reactive/src/reactive_allocator_stubs.c new file mode 100644 index 0000000000..fa44418a9a --- /dev/null +++ b/analysis/reactive/src/reactive_allocator_stubs.c @@ -0,0 +1,188 @@ +#include +#include +#include +#include +#include + +#include +#include + +typedef struct { + value *data; + intnat capacity; + int in_use; +} reactive_block; + +static reactive_block *reactive_blocks = NULL; +static intnat reactive_blocks_capacity = 0; +static intnat reactive_live_block_count = 0; +static intnat reactive_live_block_capacity_slots = 0; + +static void reactive_abort_oom(void) { + fputs("reactive allocator: out of memory\n", stderr); + abort(); +} + +static void *reactive_xrealloc(void *ptr, size_t size) { + void *next = realloc(ptr, size); + if (next == NULL && size != 0) { + reactive_abort_oom(); + } + return next; +} + +static void reactive_ensure_block_registry(void) { + intnat old_capacity; + intnat new_capacity; + + if (reactive_blocks == NULL) { + reactive_blocks_capacity = 16; + reactive_blocks = + reactive_xrealloc(NULL, (size_t)reactive_blocks_capacity * sizeof(*reactive_blocks)); + memset(reactive_blocks, 0, + (size_t)reactive_blocks_capacity * sizeof(*reactive_blocks)); + return; + } + + for (old_capacity = 0; old_capacity < reactive_blocks_capacity; old_capacity++) { + if (!reactive_blocks[old_capacity].in_use) { + return; + } + } + + old_capacity = reactive_blocks_capacity; + new_capacity = old_capacity * 2; + reactive_blocks = + reactive_xrealloc(reactive_blocks, (size_t)new_capacity * sizeof(*reactive_blocks)); + memset(reactive_blocks + old_capacity, 0, + (size_t)(new_capacity - old_capacity) * sizeof(*reactive_blocks)); + reactive_blocks_capacity = new_capacity; +} + +static intnat reactive_alloc_block_slot(void) { + intnat index; + + reactive_ensure_block_registry(); + for (index = 0; index < reactive_blocks_capacity; index++) { + if (!reactive_blocks[index].in_use) { + reactive_blocks[index].in_use = 1; + reactive_blocks[index].data = NULL; + reactive_blocks[index].capacity = 0; + return index; + } + } + + abort(); +} + +static reactive_block *reactive_block_of_handle(value handle) { + return &reactive_blocks[Int_val(handle)]; +} + +static void reactive_resize_block(reactive_block *block, intnat capacity) { + intnat old_capacity; + intnat target_capacity = capacity > 0 ? capacity : 1; + + old_capacity = block->capacity; + block->data = + reactive_xrealloc(block->data, (size_t)target_capacity * sizeof(value)); + if (target_capacity > old_capacity) { + memset(block->data + old_capacity, 0, + (size_t)(target_capacity - old_capacity) * sizeof(value)); + } + block->capacity = target_capacity; + reactive_live_block_capacity_slots += target_capacity - old_capacity; +} + +value caml_reactive_allocator_create(value capacity) { + intnat slot = reactive_alloc_block_slot(); + reactive_block *block = &reactive_blocks[slot]; + + reactive_live_block_count += 1; + reactive_resize_block(block, Int_val(capacity)); + return Val_int(slot); +} + +value caml_reactive_allocator_destroy(value handle) { + reactive_block *block = reactive_block_of_handle(handle); + + free(block->data); + reactive_live_block_capacity_slots -= block->capacity; + block->data = NULL; + block->capacity = 0; + block->in_use = 0; + reactive_live_block_count -= 1; + return Val_unit; +} + +value caml_reactive_allocator_capacity(value handle) { + reactive_block *block = reactive_block_of_handle(handle); + return Val_int(block->capacity); +} + +value caml_reactive_allocator_slot_size_bytes(value unit) { + (void)unit; + return Val_int(sizeof(value)); +} + +value caml_reactive_allocator_live_block_count(value unit) { + (void)unit; + return Val_int(reactive_live_block_count); +} + +value caml_reactive_allocator_live_block_capacity_slots(value unit) { + (void)unit; + return Val_int(reactive_live_block_capacity_slots); +} + +value caml_reactive_allocator_reset(value unit) { + intnat index; + (void)unit; + + for (index = 0; index < reactive_blocks_capacity; index++) { + reactive_block *block = &reactive_blocks[index]; + if (block->in_use) { + free(block->data); + block->data = NULL; + block->capacity = 0; + block->in_use = 0; + } + } + + reactive_live_block_count = 0; + reactive_live_block_capacity_slots = 0; + return Val_unit; +} + +value caml_reactive_allocator_resize(value handle, value capacity) { + reactive_block *block = reactive_block_of_handle(handle); + + reactive_resize_block(block, Int_val(capacity)); + return Val_unit; +} + +value caml_reactive_allocator_get(value handle, value index) { + reactive_block *block = reactive_block_of_handle(handle); + return block->data[Int_val(index)]; +} + +value caml_reactive_allocator_set(value handle, value index, value data) { + reactive_block *block = reactive_block_of_handle(handle); + + block->data[Int_val(index)] = data; + return Val_unit; +} + +value caml_reactive_allocator_blit(value src_handle, value src_pos, value dst_handle, + value dst_pos, value len) { + reactive_block *src = reactive_block_of_handle(src_handle); + reactive_block *dst = reactive_block_of_handle(dst_handle); + + memmove(dst->data + Int_val(dst_pos), src->data + Int_val(src_pos), + (size_t)Int_val(len) * sizeof(value)); + return Val_unit; +} + +value caml_reactive_value_is_young(value data) { + return Val_bool(Is_block(data) && Is_young(data)); +} diff --git a/analysis/reactive/test/AllocMeasure.ml b/analysis/reactive/test/AllocMeasure.ml new file mode 100644 index 0000000000..f37393ea6a --- /dev/null +++ b/analysis/reactive/test/AllocMeasure.ml @@ -0,0 +1,19 @@ +(** Zero-overhead allocation measurement. + + [Gc.minor_words ()] boxes a float (2 words per call). This module + subtracts that overhead so callers see only their own allocations. + + Usage: + {[ + ignore (AllocMeasure.words_since ()); (* reset *) + (* ... code under test ... *) + let words = AllocMeasure.words_since () in (* read delta *) + ]} *) + +let words_since = + let last = ref 0. in + fun () -> + let now = Gc.minor_words () in + let delta = now -. !last -. 2. in + last := now; + int_of_float delta diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml new file mode 100644 index 0000000000..6b19aacb17 --- /dev/null +++ b/analysis/reactive/test/AllocTest.ml @@ -0,0 +1,574 @@ +(** Allocation measurement for reactive combinators. + + Calls combinator internals directly (bypassing the source/emit + layer) to measure only the combinator's own allocations. *) + +open TestHelpers + +let check_alloc = + match Sys.getenv_opt "RESCRIPT_REACTIVE_SKIP_ALLOC_ASSERT" with + | Some ("1" | "true" | "TRUE" | "yes" | "YES") -> false + | _ -> true + +let words_since = AllocMeasure.words_since + +let stable_int = Stable.int +let stable_unit = Stable.unit + +let print_stable_usage () = + let blocks = Allocator.live_block_count () in + let slots = Allocator.live_block_capacity_slots () in + let bytes = slots * Allocator.slot_size_bytes in + Printf.printf " stable: blocks=%d slots=%d bytes=%d\n" blocks slots bytes + +let reset_stable_state () = + Reactive.reset (); + Allocator.reset (); + assert (Allocator.live_block_count () = 0); + assert (Allocator.live_block_capacity_slots () = 0) + +let print_stable_snapshot label = + let blocks = Allocator.live_block_count () in + let slots = Allocator.live_block_capacity_slots () in + let bytes = slots * Allocator.slot_size_bytes in + Printf.printf " %s: blocks=%d slots=%d bytes=%d\n" label blocks slots bytes + +(* ---- Fixpoint allocation ---- *) + +let test_fixpoint_alloc_n n = + let edge_values = Array.init (max 0 (n - 1)) (fun i -> [i + 1]) in + Gc.full_major (); + let root_snap = StableWave.create ~max_entries:1 () in + let edge_snap = StableWave.create ~max_entries:n () in + let remove_root = StableWave.create ~max_entries:1 () in + let add_root = StableWave.create ~max_entries:1 () in + let no_edges = StableWave.create ~max_entries:1 () in + let state = ReactiveFixpoint.create ~max_nodes:n ~max_edges:n in + + (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) + StableWave.push root_snap (stable_int 0) stable_unit; + for i = 0 to n - 2 do + StableWave.push edge_snap (stable_int i) + (Stable.of_value (StableList.unsafe_of_list edge_values.(i))) + done; + ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; + assert (ReactiveFixpoint.current_length state = n); + + (* Pre-build waves once *) + StableWave.push remove_root (stable_int 0) Maybe.none_stable; + StableWave.push add_root (stable_int 0) + (Maybe.to_stable (Maybe.some Stable.unit)); + + (* Warmup *) + for _ = 1 to 5 do + ReactiveFixpoint.apply_wave state ~roots:remove_root ~edges:no_edges; + ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges + done; + assert (ReactiveFixpoint.current_length state = n); + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + ReactiveFixpoint.apply_wave state ~roots:remove_root ~edges:no_edges; + ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges + done; + assert (ReactiveFixpoint.current_length state = n); + StableWave.destroy root_snap; + StableWave.destroy edge_snap; + StableWave.destroy remove_root; + StableWave.destroy add_root; + StableWave.destroy no_edges; + ReactiveFixpoint.destroy state; + words_since () / iters + +let test_fixpoint_alloc () = + reset_stable_state (); + Printf.printf "=== Test: fixpoint allocation ===\n"; + List.iter + (fun n -> + let words = test_fixpoint_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- FlatMap allocation ---- *) + +let test_flatmap_alloc_n n = + let state = + ReactiveFlatMap.create + ~f:(fun k v wave -> StableWave.push wave k v) + ~merge:(fun _l r -> r) + in + + (* Populate: n entries *) + for i = 0 to n - 1 do + ReactiveFlatMap.push state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveFlatMap.process state); + assert (ReactiveFlatMap.target_length state = n); + + (* Warmup: toggle all entries (remove all, re-add all) *) + for _ = 1 to 5 do + for i = 0 to n - 1 do + ReactiveFlatMap.push state (stable_int i) Maybe.none_stable + done; + ignore (ReactiveFlatMap.process state); + assert (ReactiveFlatMap.target_length state = 0); + for i = 0 to n - 1 do + ReactiveFlatMap.push state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveFlatMap.process state); + assert (ReactiveFlatMap.target_length state = n) + done; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + for i = 0 to n - 1 do + ReactiveFlatMap.push state (stable_int i) Maybe.none_stable + done; + ignore (ReactiveFlatMap.process state); + for i = 0 to n - 1 do + ReactiveFlatMap.push state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveFlatMap.process state) + done; + assert (ReactiveFlatMap.target_length state = n); + ReactiveFlatMap.destroy state; + words_since () / iters + +let test_flatmap_alloc () = + reset_stable_state (); + Printf.printf "=== Test: flatMap allocation ===\n"; + List.iter + (fun n -> + let words = test_flatmap_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- Union allocation ---- *) + +let test_union_alloc_n n = + let state = ReactiveUnion.create ~merge:(fun _l r -> r) in + + (* Populate: n entries on the left side *) + for i = 0 to n - 1 do + ReactiveUnion.push_left state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveUnion.process state); + assert (ReactiveUnion.target_length state = n); + + (* Warmup: toggle all entries (remove all, re-add all) *) + for _ = 1 to 5 do + for i = 0 to n - 1 do + ReactiveUnion.push_left state (stable_int i) Maybe.none_stable + done; + ignore (ReactiveUnion.process state); + assert (ReactiveUnion.target_length state = 0); + for i = 0 to n - 1 do + ReactiveUnion.push_left state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveUnion.process state); + assert (ReactiveUnion.target_length state = n) + done; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + for i = 0 to n - 1 do + ReactiveUnion.push_left state (stable_int i) Maybe.none_stable + done; + ignore (ReactiveUnion.process state); + for i = 0 to n - 1 do + ReactiveUnion.push_left state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveUnion.process state) + done; + assert (ReactiveUnion.target_length state = n); + ReactiveUnion.destroy state; + words_since () / iters + +let test_union_alloc () = + reset_stable_state (); + Printf.printf "=== Test: union allocation ===\n"; + List.iter + (fun n -> + let words = test_union_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- Join allocation ---- *) + +let test_join_alloc_n n = + let right_tbl = StableMap.create () in + let state = + ReactiveJoin.create + ~key_of:(fun k _v -> k) + ~f:(fun k v right_mb wave -> + if Maybe.is_some right_mb then + let v_val = Stable.to_linear_value v in + let r_val = Stable.to_linear_value (Maybe.unsafe_get right_mb) in + StableWave.push wave k (Stable.int (v_val + r_val))) + ~merge:(fun _l r -> r) + ~right_get:(fun k -> + let mb = StableMap.find_maybe right_tbl k in + if Maybe.is_some mb then + Maybe.some + (Stable.unsafe_of_value + (Stable.to_linear_value (Maybe.unsafe_get mb))) + else Maybe.none) + in + + (* Populate: n entries on the right, n on the left *) + for i = 0 to n - 1 do + StableMap.replace right_tbl (Stable.unsafe_of_value i) + (Stable.unsafe_of_value (i * 10)) + done; + for i = 0 to n - 1 do + ReactiveJoin.push_left state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveJoin.process state); + assert (ReactiveJoin.target_length state = n); + + (* Warmup: toggle all left entries *) + for _ = 1 to 5 do + for i = 0 to n - 1 do + ReactiveJoin.push_left state (stable_int i) Maybe.none_stable + done; + ignore (ReactiveJoin.process state); + assert (ReactiveJoin.target_length state = 0); + for i = 0 to n - 1 do + ReactiveJoin.push_left state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveJoin.process state); + assert (ReactiveJoin.target_length state = n) + done; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + for i = 0 to n - 1 do + ReactiveJoin.push_left state (stable_int i) Maybe.none_stable + done; + ignore (ReactiveJoin.process state); + for i = 0 to n - 1 do + ReactiveJoin.push_left state (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + ignore (ReactiveJoin.process state) + done; + assert (ReactiveJoin.target_length state = n); + ReactiveJoin.destroy state; + StableMap.destroy right_tbl; + words_since () / iters + +let test_join_alloc () = + reset_stable_state (); + Printf.printf "=== Test: join allocation ===\n"; + List.iter + (fun n -> + let words = test_join_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- Reactive.join end-to-end allocation ---- *) + +let test_reactive_join_alloc_n n = + Reactive.reset (); + let left, emit_left = Reactive.Source.create ~name:"left" () in + let right, emit_right = Reactive.Source.create ~name:"right" () in + + (* Join: for each (k, v) in left, look up k in right, produce (k, v + right_v) *) + let joined = + Reactive.Join.create ~name:"joined" left right + ~key_of:(fun k _v -> k) + ~f:(fun k v right_mb wave -> + if Maybe.is_some right_mb then + let v_val = Stable.to_linear_value v in + let r_val = Stable.to_linear_value (Maybe.unsafe_get right_mb) in + StableWave.push wave k (Stable.int (v_val + r_val))) + () + in + + (* Populate: n entries on right, then n entries on left *) + for i = 0 to n - 1 do + emit_set emit_right i (i * 10) + done; + for i = 0 to n - 1 do + emit_set emit_left i i + done; + assert (Reactive.length joined = n); + + (* Pre-build waves for the hot loop: toggle all left entries *) + let remove_wave = StableWave.create ~max_entries:n () in + for i = 0 to n - 1 do + StableWave.push remove_wave (stable_int i) Maybe.none_stable + done; + let add_wave = StableWave.create ~max_entries:n () in + for i = 0 to n - 1 do + StableWave.push add_wave (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + + (* Warmup *) + for _ = 1 to 5 do + emit_left remove_wave; + assert (Reactive.length joined = 0); + emit_left add_wave; + assert (Reactive.length joined = n) + done; + ignore emit_right; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + emit_left remove_wave; + emit_left add_wave + done; + assert (Reactive.length joined = n); + StableWave.destroy remove_wave; + StableWave.destroy add_wave; + Reactive.destroy_graph (); + words_since () / iters + +let test_reactive_join_alloc () = + reset_stable_state (); + Printf.printf "=== Test: Reactive.join allocation ===\n"; + List.iter + (fun n -> + let words = test_reactive_join_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- Reactive.fixpoint end-to-end allocation ---- *) + +let test_reactive_fixpoint_alloc_n n = + Reactive.reset (); + let edge_values = Array.init (max 0 (n - 1)) (fun i -> [i + 1]) in + Gc.full_major (); + let edge_values_stable = Array.map StableList.of_list edge_values in + let init, emit_root = Reactive.Source.create ~name:"init" () in + let edges, emit_edges = Reactive.Source.create ~name:"edges" () in + + (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) + let edge_wave = StableWave.create ~max_entries:(max 1 (n - 1)) () in + StableWave.clear edge_wave; + for i = 0 to n - 2 do + StableWave.push edge_wave (stable_int i) + (StableList.maybe_to_stable (Maybe.some edge_values_stable.(i))) + done; + emit_edges edge_wave; + let reachable = Reactive.Fixpoint.create ~name:"reachable" ~init ~edges () in + + (* Add root to populate *) + emit_set emit_root 0 (); + assert (Reactive.length reachable = n); + + (* Pre-build waves for the hot loop *) + let remove_wave = StableWave.create ~max_entries:1 () in + StableWave.push remove_wave (stable_int 0) Maybe.none_stable; + let add_wave = StableWave.create ~max_entries:1 () in + StableWave.push add_wave (stable_int 0) + (Maybe.to_stable (Maybe.some Stable.unit)); + + (* Warmup *) + for _ = 1 to 5 do + emit_root remove_wave; + assert (Reactive.length reachable = 0); + emit_root add_wave; + assert (Reactive.length reachable = n) + done; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + emit_root remove_wave; + emit_root add_wave + done; + assert (Reactive.length reachable = n); + StableWave.destroy edge_wave; + StableWave.destroy remove_wave; + StableWave.destroy add_wave; + Reactive.destroy_graph (); + words_since () / iters + +let test_reactive_fixpoint_alloc () = + reset_stable_state (); + Printf.printf "=== Test: Reactive.fixpoint allocation ===\n"; + List.iter + (fun n -> + let words = test_reactive_fixpoint_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- Reactive.union end-to-end allocation ---- *) + +let test_reactive_union_alloc_n n = + Reactive.reset (); + let left, emit_left = Reactive.Source.create ~name:"left" () in + let right, emit_right = Reactive.Source.create ~name:"right" () in + + let merged = Reactive.Union.create ~name:"merged" left right () in + + (* Populate: n entries on the left side *) + for i = 0 to n - 1 do + emit_set emit_left i i + done; + assert (Reactive.length merged = n); + + (* Pre-build waves: single wave with all n entries *) + let remove_wave = StableWave.create ~max_entries:n () in + for i = 0 to n - 1 do + StableWave.push remove_wave (stable_int i) Maybe.none_stable + done; + let add_wave = StableWave.create ~max_entries:n () in + for i = 0 to n - 1 do + StableWave.push add_wave (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + + (* Warmup *) + for _ = 1 to 5 do + emit_left remove_wave; + assert (Reactive.length merged = 0); + emit_left add_wave; + assert (Reactive.length merged = n) + done; + ignore emit_right; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + emit_left remove_wave; + emit_left add_wave + done; + assert (Reactive.length merged = n); + StableWave.destroy remove_wave; + StableWave.destroy add_wave; + Reactive.destroy_graph (); + words_since () / iters + +let test_reactive_union_alloc () = + reset_stable_state (); + Printf.printf "=== Test: Reactive.union allocation ===\n"; + List.iter + (fun n -> + let words = test_reactive_union_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +(* ---- Reactive.flatMap end-to-end allocation ---- *) + +let test_reactive_flatmap_alloc_n n = + Reactive.reset (); + let src, emit_src = Reactive.Source.create ~name:"src" () in + + let derived = + Reactive.FlatMap.create ~name:"derived" src + ~f:(fun k v wave -> StableWave.push wave k v) + () + in + + (* Populate: n entries *) + for i = 0 to n - 1 do + emit_set emit_src i i + done; + assert (Reactive.length derived = n); + + (* Pre-build waves *) + let remove_wave = StableWave.create ~max_entries:n () in + for i = 0 to n - 1 do + StableWave.push remove_wave (stable_int i) Maybe.none_stable + done; + let add_wave = StableWave.create ~max_entries:n () in + for i = 0 to n - 1 do + StableWave.push add_wave (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) + done; + + (* Warmup *) + for _ = 1 to 5 do + emit_src remove_wave; + assert (Reactive.length derived = 0); + emit_src add_wave; + assert (Reactive.length derived = n) + done; + + (* Measure *) + let iters = 100 in + ignore (words_since ()); + for _ = 1 to iters do + emit_src remove_wave; + emit_src add_wave + done; + assert (Reactive.length derived = n); + StableWave.destroy remove_wave; + StableWave.destroy add_wave; + Reactive.destroy_graph (); + words_since () / iters + +let test_reactive_flatmap_alloc () = + reset_stable_state (); + Printf.printf "=== Test: Reactive.flatMap allocation ===\n"; + List.iter + (fun n -> + let words = test_reactive_flatmap_alloc_n n in + Printf.printf " n=%d: %d words/iter\n" n words; + if check_alloc then assert (words = 0)) + [10; 100; 1000]; + print_stable_usage (); + assert (Allocator.live_block_count () = 0); + Printf.printf "PASSED\n\n" + +let run_all () = + Printf.printf "\n====== Allocation Tests ======\n\n"; + test_union_alloc (); + test_flatmap_alloc (); + test_join_alloc (); + test_fixpoint_alloc (); + test_reactive_union_alloc (); + test_reactive_flatmap_alloc (); + test_reactive_join_alloc (); + test_reactive_fixpoint_alloc () diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 4c750d16cf..b407226600 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -7,9 +7,14 @@ let test_batch_flatmap () = reset (); Printf.printf "=== Test: batch flatmap ===\n"; - let source, emit = source ~name:"source" () in + let source, emit = Source.create ~name:"source" () in let derived = - flatMap ~name:"derived" source ~f:(fun k v -> [(k ^ "_derived", v * 2)]) () + FlatMap.create ~name:"derived" source + ~f:(fun k v wave -> + StableWave.push wave + (Stable.unsafe_of_value (Stable.to_linear_value k ^ "_derived")) + (Stable.int (Stable.to_linear_value v * 2))) + () in (* Subscribe to track what comes out *) @@ -17,23 +22,21 @@ let test_batch_flatmap () = let received_entries = ref [] in subscribe (function - | Batch entries -> + | entries -> incr received_batches; - received_entries := entries @ !received_entries - | Set (k, v) -> received_entries := [(k, Some v)] @ !received_entries - | Remove k -> received_entries := [(k, None)] @ !received_entries) + received_entries := entries @ !received_entries) derived; (* Send a batch *) - emit_batch [set "a" 1; set "b" 2; set "c" 3] emit; + emit_sets emit [("a", 1); ("b", 2); ("c", 3)]; Printf.printf "Received batches: %d, entries: %d\n" !received_batches (List.length !received_entries); assert (!received_batches = 1); assert (List.length !received_entries = 3); - assert (get derived "a_derived" = Some 2); - assert (get derived "b_derived" = Some 4); - assert (get derived "c_derived" = Some 6); + assert (get_opt derived "a_derived" = Some 2); + assert (get_opt derived "b_derived" = Some 4); + assert (get_opt derived "c_derived" = Some 6); Printf.printf "PASSED\n\n" @@ -41,43 +44,38 @@ let test_batch_fixpoint () = reset (); Printf.printf "=== Test: batch fixpoint ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Track batches received *) let batch_count = ref 0 in let total_added = ref 0 in subscribe (function - | Batch entries -> + | entries -> incr batch_count; entries - |> List.iter (fun (_, v_opt) -> - match v_opt with - | Some () -> incr total_added - | None -> ()) - | Set (_, ()) -> incr total_added - | Remove _ -> ()) + |> List.iter (fun (_, mv) -> if Maybe.is_some mv then incr total_added)) fp; (* Set up edges first *) - emit_edges (Set ("a", ["b"; "c"])); - emit_edges (Set ("b", ["d"])); + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "b" ["d"]; (* Send batch of roots *) - emit_batch [set "a" (); set "x" ()] emit_init; + emit_sets emit_init [("a", ()); ("x", ())]; Printf.printf "Batch count: %d, total added: %d\n" !batch_count !total_added; Printf.printf "fp length: %d\n" (length fp); (* Should have a, b, c, d (reachable from a) and x (standalone root) *) assert (length fp = 5); - assert (get fp "a" = Some ()); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); - assert (get fp "d" = Some ()); - assert (get fp "x" = Some ()); + assert (get_opt fp "a" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); + assert (get_opt fp "d" = Some ()); + assert (get_opt fp "x" = Some ()); Printf.printf "PASSED\n\n" diff --git a/analysis/reactive/test/FixpointBasicTest.ml b/analysis/reactive/test/FixpointBasicTest.ml index b978ea9468..afe700f8b5 100644 --- a/analysis/reactive/test/FixpointBasicTest.ml +++ b/analysis/reactive/test/FixpointBasicTest.ml @@ -1,53 +1,54 @@ (** Basic fixpoint graph traversal tests *) open Reactive +open TestHelpers let test_fixpoint () = reset (); Printf.printf "Test: fixpoint\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Set up graph: 1 -> [2, 3], 2 -> [4], 3 -> [4] *) - emit_edges (Set (1, [2; 3])); - emit_edges (Set (2, [4])); - emit_edges (Set (3, [4])); + emit_edge_set emit_edges 1 [2; 3]; + emit_edge_set emit_edges 2 [4]; + emit_edge_set emit_edges 3 [4]; (* Compute fixpoint *) - let reachable = fixpoint ~name:"reachable" ~init ~edges () in + let reachable = Fixpoint.create ~name:"reachable" ~init ~edges () in (* Initially empty *) Printf.printf "Initially: length=%d\n" (length reachable); assert (length reachable = 0); (* Add root 1 *) - emit_init (Set (1, ())); + emit_set emit_init 1 (); Printf.printf "After adding root 1: length=%d\n" (length reachable); assert (length reachable = 4); (* 1, 2, 3, 4 *) - assert (get reachable 1 = Some ()); - assert (get reachable 2 = Some ()); - assert (get reachable 3 = Some ()); - assert (get reachable 4 = Some ()); - assert (get reachable 5 = None); + assert (get_opt reachable 1 = Some ()); + assert (get_opt reachable 2 = Some ()); + assert (get_opt reachable 3 = Some ()); + assert (get_opt reachable 4 = Some ()); + assert (get_opt reachable 5 = None); (* Add another root 5 with edge 5 -> [6] *) - emit_edges (Set (5, [6])); - emit_init (Set (5, ())); + emit_edge_set emit_edges 5 [6]; + emit_set emit_init 5 (); Printf.printf "After adding root 5: length=%d\n" (length reachable); assert (length reachable = 6); (* 1, 2, 3, 4, 5, 6 *) - (* Remove root 1 *) - emit_init (Remove 1); + (* remove root 1 *) + emit_remove emit_init 1; Printf.printf "After removing root 1: length=%d\n" (length reachable); assert (length reachable = 2); (* 5, 6 *) - assert (get reachable 1 = None); - assert (get reachable 5 = Some ()); - assert (get reachable 6 = Some ()); + assert (get_opt reachable 1 = None); + assert (get_opt reachable 5 = Some ()); + assert (get_opt reachable 6 = Some ()); Printf.printf "PASSED\n\n" @@ -55,22 +56,22 @@ let test_fixpoint_basic_expansion () = reset (); Printf.printf "=== Test: fixpoint basic expansion ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 3); - assert (get fp "a" = Some ()); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); - assert (get fp "d" = None); + assert (get_opt fp "a" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); + assert (get_opt fp "d" = None); Printf.printf "PASSED\n\n" @@ -78,23 +79,23 @@ let test_fixpoint_multiple_roots () = reset (); Printf.printf "=== Test: fixpoint multiple roots ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, c -> d (disconnected components) *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("c", ["d"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "c" ["d"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); - emit_init (Set ("c", ())); + emit_set emit_init "a" (); + emit_set emit_init "c" (); assert (length fp = 4); - assert (get fp "a" = Some ()); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); - assert (get fp "d" = Some ()); + assert (get_opt fp "a" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); + assert (get_opt fp "d" = Some ()); Printf.printf "PASSED\n\n" @@ -102,17 +103,17 @@ let test_fixpoint_diamond () = reset (); Printf.printf "=== Test: fixpoint diamond ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, a -> c, b -> d, c -> d *) - emit_edges (Set ("a", ["b"; "c"])); - emit_edges (Set ("b", ["d"])); - emit_edges (Set ("c", ["d"])); + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "b" ["d"]; + emit_edge_set emit_edges "c" ["d"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 4); @@ -122,22 +123,22 @@ let test_fixpoint_cycle () = reset (); Printf.printf "=== Test: fixpoint cycle ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c -> b (cycle from root) *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); - emit_edges (Set ("c", ["b"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 3); - assert (get fp "a" = Some ()); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); + assert (get_opt fp "a" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); Printf.printf "PASSED\n\n" @@ -145,12 +146,12 @@ let test_fixpoint_empty_base () = reset (); Printf.printf "=== Test: fixpoint empty base ===\n"; - let init, _emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, _emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - emit_edges (Set ("a", ["b"])); + emit_edge_set emit_edges "a" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in assert (length fp = 0); @@ -160,18 +161,18 @@ let test_fixpoint_self_loop () = reset (); Printf.printf "=== Test: fixpoint self loop ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> a (self loop) *) - emit_edges (Set ("a", ["a"])); + emit_edge_set emit_edges "a" ["a"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 1); - assert (get fp "a" = Some ()); + assert (get_opt fp "a" = Some ()); Printf.printf "PASSED\n\n" @@ -180,23 +181,23 @@ let test_fixpoint_existing_data () = Printf.printf "=== Test: fixpoint with existing data ===\n"; (* Create source and pre-populate *) - let init, emit_init = source ~name:"init" () in - emit_init (Set ("root", ())); + let init, emit_init = Source.create ~name:"init" () in + emit_set emit_init "root" (); - let edges, emit_edges = source ~name:"edges" () in - emit_edges (Set ("root", ["a"; "b"])); - emit_edges (Set ("a", ["c"])); + let edges, emit_edges = Source.create ~name:"edges" () in + emit_edge_set emit_edges "root" ["a"; "b"]; + emit_edge_set emit_edges "a" ["c"]; (* Create fixpoint - should immediately have all reachable *) - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in Printf.printf "Fixpoint length: %d (expected 4)\n" (length fp); assert (length fp = 4); (* root, a, b, c *) - assert (get fp "root" = Some ()); - assert (get fp "a" = Some ()); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); + assert (get_opt fp "root" = Some ()); + assert (get_opt fp "a" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); Printf.printf "PASSED\n\n" diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/FixpointIncrementalTest.ml index e0c2d0b6cb..7a3e8578ae 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -7,16 +7,16 @@ let test_fixpoint_add_base () = reset (); Printf.printf "=== Test: fixpoint add base ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, c -> d *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("c", ["d"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "c" ["d"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 2); (* a, b *) @@ -26,17 +26,14 @@ let test_fixpoint_add_base () = let removed = ref [] in subscribe (function - | Set (k, ()) -> added := k :: !added - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> entries - |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + |> List.iter (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed)) fp; - emit_init (Set ("c", ())); + emit_set emit_init "c" (); Printf.printf "Added: [%s]\n" (String.concat ", " !added); assert (List.length !added = 2); @@ -52,30 +49,29 @@ let test_fixpoint_remove_base () = reset (); Printf.printf "=== Test: fixpoint remove base ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 3); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - emit_init (Remove "a"); + emit_remove emit_init "a"; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (List.length !removed = 3); @@ -87,28 +83,26 @@ let test_fixpoint_add_edge () = reset (); Printf.printf "=== Test: fixpoint add edge ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 1); (* just a *) let added = ref [] in subscribe (function - | Set (k, ()) -> added := k :: !added - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = Some () then added := k :: !added) - entries - | _ -> ()) + (fun (k, mv) -> if Maybe.is_some mv then added := k :: !added) + entries) fp; (* Add edge a -> b *) - emit_edges (Set ("a", ["b"])); + emit_edge_set emit_edges "a" ["b"]; Printf.printf "Added: [%s]\n" (String.concat ", " !added); assert (List.mem "b" !added); @@ -120,31 +114,30 @@ let test_fixpoint_remove_edge () = reset (); Printf.printf "=== Test: fixpoint remove edge ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 3); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove edge a -> b *) - emit_edges (Set ("a", [])); + (* remove edge a -> b *) + emit_edge_set emit_edges "a" []; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (List.length !removed = 2); @@ -158,32 +151,31 @@ let test_fixpoint_cycle_removal () = reset (); Printf.printf "=== Test: fixpoint cycle removal (well-founded) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c -> b (b-c cycle reachable from a) *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); - emit_edges (Set ("c", ["b"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 3); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove edge a -> b *) - emit_edges (Set ("a", [])); + (* remove edge a -> b *) + emit_edge_set emit_edges "a" []; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* Both b and c should be removed - cycle has no well-founded support *) @@ -199,32 +191,31 @@ let test_fixpoint_alternative_support () = reset (); Printf.printf "=== Test: fixpoint alternative support ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, a -> c -> b If we remove a -> b, b should survive via a -> c -> b *) - emit_edges (Set ("a", ["b"; "c"])); - emit_edges (Set ("c", ["b"])); + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 3); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove direct edge a -> b (but keep a -> c) *) - emit_edges (Set ("a", ["c"])); + (* remove direct edge a -> b (but keep a -> c) *) + emit_edge_set emit_edges "a" ["c"]; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* b should NOT be removed - still reachable via c *) @@ -237,25 +228,23 @@ let test_fixpoint_deltas () = reset (); Printf.printf "=== Test: fixpoint delta emissions ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - emit_edges (Set (1, [2; 3])); - emit_edges (Set (2, [4])); + emit_edge_set emit_edges 1 [2; 3]; + emit_edge_set emit_edges 2 [4]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Count entries, not deltas - V2 emits batches *) let all_entries = ref [] in subscribe (function - | Set (k, v) -> all_entries := (k, Some v) :: !all_entries - | Remove k -> all_entries := (k, None) :: !all_entries - | Batch entries -> all_entries := entries @ !all_entries) + | entries -> all_entries := entries @ !all_entries) fp; (* Add root *) - emit_init (Set (1, ())); + emit_set emit_init 1 (); Printf.printf "After add root: %d entries\n" (List.length !all_entries); assert (List.length !all_entries = 4); @@ -263,75 +252,72 @@ let test_fixpoint_deltas () = all_entries := []; (* Add edge 3 -> 5 *) - emit_edges (Set (3, [5])); + emit_edge_set emit_edges 3 [5]; Printf.printf "After add edge 3->5: %d entries\n" (List.length !all_entries); assert (List.length !all_entries = 1); (* 5 added *) all_entries := []; - (* Remove root (should remove all) *) - emit_init (Remove 1); + (* remove root (should remove all) *) + emit_remove emit_init 1; Printf.printf "After remove root: %d entries\n" (List.length !all_entries); assert (List.length !all_entries = 5); (* 1, 2, 3, 4, 5 removed *) Printf.printf "PASSED\n\n" -(* Test: Remove from init but still reachable via edges *) +(* Test: remove from init but still reachable via edges *) let test_fixpoint_remove_spurious_root () = reset (); Printf.printf "=== Test: fixpoint remove spurious root (still reachable) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Track all deltas *) let added = ref [] in let removed = ref [] in subscribe (function - | Set (k, ()) -> added := k :: !added - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> entries - |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + |> List.iter (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed)) fp; (* Step 1: "b" is spuriously marked as a root *) - emit_init (Set ("b", ())); + emit_set emit_init "b" (); Printf.printf "After spurious root b: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); - assert (get fp "b" = Some ()); + assert (get_opt fp "b" = Some ()); (* Step 2: The real root "root" is added *) - emit_init (Set ("root", ())); + emit_set emit_init "root" (); Printf.printf "After true root: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); (* Step 3: Edge root -> a is added *) - emit_edges (Set ("root", ["a"])); + emit_edge_set emit_edges "root" ["a"]; Printf.printf "After edge root->a: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); - assert (get fp "a" = Some ()); + assert (get_opt fp "a" = Some ()); (* Step 4: Edge a -> b is added *) - emit_edges (Set ("a", ["b"])); + emit_edge_set emit_edges "a" ["b"]; Printf.printf "After edge a->b: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 3); @@ -340,17 +326,17 @@ let test_fixpoint_remove_spurious_root () = removed := []; (* Step 5: The spurious root "b" is REMOVED from init *) - emit_init (Remove "b"); + emit_remove emit_init "b"; Printf.printf "After removing b from init: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* b should NOT be removed - still reachable via a *) assert (not (List.mem "b" !removed)); - assert (get fp "b" = Some ()); + assert (get_opt fp "b" = Some ()); assert (length fp = 3); Printf.printf "PASSED\n\n" @@ -360,52 +346,51 @@ let test_fixpoint_remove_edge_entry_alternative_source () = Printf.printf "=== Test: fixpoint remove edge entry (alternative source) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Set up initial edges: a -> b, c -> b *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("c", ["b"])); + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Track changes *) let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; (* Add roots a and c *) - emit_init (Set ("a", ())); - emit_init (Set ("c", ())); + emit_set emit_init "a" (); + emit_set emit_init "c" (); Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 3); removed := []; - (* Remove entire edge entry for "a" *) - emit_edges (Remove "a"); + (* remove entire edge entry for "a" *) + emit_remove emit_edges "a"; - Printf.printf "After Remove edge entry 'a': fp=[%s]\n" + Printf.printf "After remove edge entry 'a': fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* b should NOT be removed - still reachable via c -> b *) assert (not (List.mem "b" !removed)); - assert (get fp "b" = Some ()); + assert (get_opt fp "b" = Some ()); assert (length fp = 3); Printf.printf "PASSED\n\n" @@ -414,37 +399,34 @@ let test_fixpoint_remove_edge_rederivation () = reset (); Printf.printf "=== Test: fixpoint remove edge (re-derivation needed) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Track changes *) let removed = ref [] in let added = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Set (k, ()) -> added := k :: !added - | Batch entries -> + | entries -> entries - |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + |> List.iter (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed)) fp; (* Add root *) - emit_init (Set ("root", ())); + emit_set emit_init "root" (); (* Build graph: root -> a -> b -> c, a -> c *) - emit_edges (Set ("root", ["a"])); - emit_edges (Set ("a", ["b"; "c"])); - emit_edges (Set ("b", ["c"])); + emit_edge_set emit_edges "root" ["a"]; + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "b" ["c"]; Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 4); @@ -452,73 +434,72 @@ let test_fixpoint_remove_edge_rederivation () = removed := []; added := []; - (* Remove the direct edge a -> c *) - emit_edges (Set ("a", ["b"])); + (* remove the direct edge a -> c *) + emit_edge_set emit_edges "a" ["b"]; Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) (String.concat ", " !added); (* c should still be in fixpoint - reachable via root -> a -> b -> c *) - assert (get fp "c" = Some ()); + assert (get_opt fp "c" = Some ()); assert (length fp = 4); Printf.printf "PASSED\n\n" let test_fixpoint_remove_edge_entry_rederivation () = reset (); - Printf.printf "=== Test: fixpoint Remove edge entry (re-derivation) ===\n"; + Printf.printf "=== Test: fixpoint remove edge entry (re-derivation) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Set up edges before creating fixpoint *) - emit_edges (Set ("a", ["c"])); - emit_edges (Set ("b", ["c"])); + emit_edge_set emit_edges "a" ["c"]; + emit_edge_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Track changes *) let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; (* Add roots a and b *) - emit_init (Set ("a", ())); - emit_init (Set ("b", ())); + emit_set emit_init "a" (); + emit_set emit_init "b" (); Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 3); removed := []; - (* Remove entire edge entry for "a" using Remove delta *) - emit_edges (Remove "a"); + (* remove entire edge entry for "a" using remove delta *) + emit_remove emit_edges "a"; - Printf.printf "After Remove 'a' entry: fp=[%s]\n" + Printf.printf "After remove 'a' entry: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* c should survive - b -> c still exists *) assert (not (List.mem "c" !removed)); - assert (get fp "c" = Some ()); + assert (get_opt fp "c" = Some ()); assert (length fp = 3); Printf.printf "PASSED\n\n" @@ -527,58 +508,55 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = reset (); Printf.printf "=== Test: fixpoint edge removal (higher rank support) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Track changes *) let removed = ref [] in let added = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Set (k, ()) -> added := k :: !added - | Batch entries -> + | entries -> entries - |> List.iter (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed)) + |> List.iter (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed)) fp; (* Add root *) - emit_init (Set ("root", ())); + emit_set emit_init "root" (); (* Build graph: root -> a -> b -> c, a -> c *) - emit_edges (Set ("root", ["a"])); - emit_edges (Set ("a", ["b"; "c"])); - emit_edges (Set ("b", ["c"])); + emit_edge_set emit_edges "root" ["a"]; + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "b" ["c"]; Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 4); - assert (get fp "c" = Some ()); + assert (get_opt fp "c" = Some ()); removed := []; added := []; - (* Remove direct edge a -> c, keeping a -> b *) - emit_edges (Set ("a", ["b"])); + (* remove direct edge a -> c, keeping a -> b *) + emit_edge_set emit_edges "a" ["b"]; Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) (String.concat ", " !added); (* c should still be in fixpoint via root -> a -> b -> c *) - assert (get fp "c" = Some ()); + assert (get_opt fp "c" = Some ()); assert (length fp = 4); Printf.printf "PASSED\n\n" @@ -586,131 +564,128 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = let test_fixpoint_remove_edge_entry_needs_rederivation () = reset (); Printf.printf - "=== Test: fixpoint Remove edge entry (needs re-derivation) ===\n"; + "=== Test: fixpoint remove edge entry (needs re-derivation) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Pre-populate edges so fixpoint initializes with them *) - emit_edges (Set ("r", ["a"; "b"])); - emit_edges (Set ("a", ["y"])); - emit_edges (Set ("b", ["c"])); - emit_edges (Set ("c", ["x"])); - emit_edges (Set ("x", ["y"])); + emit_edge_set emit_edges "r" ["a"; "b"]; + emit_edge_set emit_edges "a" ["y"]; + emit_edge_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "c" ["x"]; + emit_edge_set emit_edges "x" ["y"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in (* Make r live *) - emit_init (Set ("r", ())); + emit_set emit_init "r" (); (* Sanity: y initially reachable via short path *) - assert (get fp "y" = Some ()); - assert (get fp "x" = Some ()); + assert (get_opt fp "y" = Some ()); + assert (get_opt fp "x" = Some ()); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove the entire edge entry for a (removes a->y) *) - emit_edges (Remove "a"); + (* remove the entire edge entry for a (removes a->y) *) + emit_remove emit_edges "a"; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* Correct: y is still reachable via r->b->c->x->y *) - assert (get fp "y" = Some ()); + assert (get_opt fp "y" = Some ()); Printf.printf "PASSED\n\n" let test_fixpoint_remove_base_needs_rederivation () = reset (); Printf.printf - "=== Test: fixpoint Remove base element (needs re-derivation) ===\n"; + "=== Test: fixpoint remove base element (needs re-derivation) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* Pre-populate edges so fixpoint initializes with them *) - emit_edges (Set ("r1", ["a"])); - emit_edges (Set ("a", ["y"])); - emit_edges (Set ("r2", ["b"])); - emit_edges (Set ("b", ["c"])); - emit_edges (Set ("c", ["x"])); - emit_edges (Set ("x", ["y"])); + emit_edge_set emit_edges "r1" ["a"]; + emit_edge_set emit_edges "a" ["y"]; + emit_edge_set emit_edges "r2" ["b"]; + emit_edge_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "c" ["x"]; + emit_edge_set emit_edges "x" ["y"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in - emit_init (Set ("r1", ())); - emit_init (Set ("r2", ())); + emit_set emit_init "r1" (); + emit_set emit_init "r2" (); (* Sanity: y initially reachable *) - assert (get fp "y" = Some ()); - assert (get fp "x" = Some ()); + assert (get_opt fp "y" = Some ()); + assert (get_opt fp "x" = Some ()); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove r1 from base: y should remain via r2 path *) - emit_init (Remove "r1"); + (* remove r1 from base: y should remain via r2 path *) + emit_remove emit_init "r1"; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); - assert (get fp "y" = Some ()); + assert (get_opt fp "y" = Some ()); Printf.printf "PASSED\n\n" let test_fixpoint_batch_overlapping_deletions () = reset (); Printf.printf "=== Test: fixpoint batch overlapping deletions ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* r -> a,b ; a -> x ; b -> x ; x -> y *) - emit_edges (Set ("r", ["a"; "b"])); - emit_edges (Set ("a", ["x"])); - emit_edges (Set ("b", ["x"])); - emit_edges (Set ("x", ["y"])); + emit_edge_set emit_edges "r" ["a"; "b"]; + emit_edge_set emit_edges "a" ["x"]; + emit_edge_set emit_edges "b" ["x"]; + emit_edge_set emit_edges "x" ["y"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in + emit_set emit_init "r" (); - assert (get fp "x" = Some ()); - assert (get fp "y" = Some ()); + assert (get_opt fp "x" = Some ()); + assert (get_opt fp "y" = Some ()); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove both supports for x in one batch. *) - emit_edges (Batch [("a", Some []); ("b", Some [])]); + (* remove both supports for x in one batch. *) + emit_edge_batch emit_edges [("a", Some []); ("b", Some [])]; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (List.mem "x" !removed); assert (List.mem "y" !removed); assert (List.length !removed = 2); - assert (get fp "x" = None); - assert (get fp "y" = None); + assert (get_opt fp "x" = None); + assert (get_opt fp "y" = None); assert (length fp = 3); (* r, a, b *) @@ -720,43 +695,40 @@ let test_fixpoint_batch_delete_add_same_wave () = reset (); Printf.printf "=== Test: fixpoint batch delete+add same wave ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* r -> a,c ; a -> x ; c -> [] *) - emit_edges (Set ("r", ["a"; "c"])); - emit_edges (Set ("a", ["x"])); - emit_edges (Set ("c", [])); + emit_edge_set emit_edges "r" ["a"; "c"]; + emit_edge_set emit_edges "a" ["x"]; + emit_edge_set emit_edges "c" []; - let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in + emit_set emit_init "r" (); - assert (get fp "x" = Some ()); + assert (get_opt fp "x" = Some ()); assert (length fp = 4); let added = ref [] in let removed = ref [] in subscribe (function - | Set (k, ()) -> added := k :: !added - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed) + (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed) entries) fp; (* In one batch: remove a->x and add c->x. x should stay live. *) - emit_edges (Batch [("a", Some []); ("c", Some ["x"])]); + emit_edge_batch emit_edges [("a", Some []); ("c", Some ["x"])]; Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) (String.concat ", " !added); - assert (get fp "x" = Some ()); + assert (get_opt fp "x" = Some ()); assert (length fp = 4); assert (!removed = []); assert (!added = []); @@ -767,37 +739,36 @@ let test_fixpoint_fanin_single_predecessor_removed () = reset (); Printf.printf "=== Test: fixpoint fan-in single predecessor removed ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* r -> a,b,c ; a,b,c -> z *) - emit_edges (Set ("r", ["a"; "b"; "c"])); - emit_edges (Set ("a", ["z"])); - emit_edges (Set ("b", ["z"])); - emit_edges (Set ("c", ["z"])); + emit_edge_set emit_edges "r" ["a"; "b"; "c"]; + emit_edge_set emit_edges "a" ["z"]; + emit_edge_set emit_edges "b" ["z"]; + emit_edge_set emit_edges "c" ["z"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in + emit_set emit_init "r" (); - assert (get fp "z" = Some ()); + assert (get_opt fp "z" = Some ()); assert (length fp = 5); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove only one predecessor contribution; z should remain live. *) - emit_edges (Set ("a", [])); + (* remove only one predecessor contribution; z should remain live. *) + emit_edge_set emit_edges "a" []; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); - assert (get fp "z" = Some ()); + assert (get_opt fp "z" = Some ()); assert (length fp = 5); assert (!removed = []); @@ -808,53 +779,52 @@ let test_fixpoint_cycle_alternative_external_support () = Printf.printf "=== Test: fixpoint cycle with alternative external support ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* r1 -> b ; r2 -> c ; b <-> c *) - emit_edges (Set ("r1", ["b"])); - emit_edges (Set ("r2", ["c"])); - emit_edges (Set ("b", ["c"])); - emit_edges (Set ("c", ["b"])); + emit_edge_set emit_edges "r1" ["b"]; + emit_edge_set emit_edges "r2" ["c"]; + emit_edge_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r1", ())); - emit_init (Set ("r2", ())); + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in + emit_set emit_init "r1" (); + emit_set emit_init "r2" (); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); let removed = ref [] in subscribe (function - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> if v_opt = None then removed := k :: !removed) - entries - | _ -> ()) + (fun (k, mv) -> + if not (Maybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove one external support edge; cycle should remain via r2 -> c. *) - emit_edges (Set ("r1", [])); + (* remove one external support edge; cycle should remain via r2 -> c. *) + emit_edge_set emit_edges "r1" []; Printf.printf "After removing r1->b, removed: [%s]\n" (String.concat ", " !removed); - assert (get fp "b" = Some ()); - assert (get fp "c" = Some ()); + assert (get_opt fp "b" = Some ()); + assert (get_opt fp "c" = Some ()); assert (!removed = []); removed := []; - (* Remove the other external support edge; cycle should now disappear. *) - emit_edges (Set ("r2", [])); + (* remove the other external support edge; cycle should now disappear. *) + emit_edge_set emit_edges "r2" []; Printf.printf "After removing r2->c, removed: [%s]\n" (String.concat ", " !removed); assert (List.mem "b" !removed); assert (List.mem "c" !removed); - assert (get fp "b" = None); - assert (get fp "c" = None); + assert (get_opt fp "b" = None); + assert (get_opt fp "c" = None); Printf.printf "PASSED\n\n" @@ -863,47 +833,44 @@ let test_fixpoint_remove_then_readd_via_expansion_same_wave () = Printf.printf "=== Test: fixpoint remove then re-add via expansion (same wave) ===\n"; - let init, emit_init = source ~name:"init" () in - let edges, emit_edges = source ~name:"edges" () in + let init, emit_init = Source.create ~name:"init" () in + let edges, emit_edges = Source.create ~name:"edges" () in (* r -> s ; s -> x ; y -> x ; then update s -> y. x is first tentatively deleted (s no longer points to x), then becomes reachable again via new path r -> s -> y -> x. *) - emit_edges (Set ("r", ["s"])); - emit_edges (Set ("s", ["x"])); - emit_edges (Set ("y", ["x"])); + emit_edge_set emit_edges "r" ["s"]; + emit_edge_set emit_edges "s" ["x"]; + emit_edge_set emit_edges "y" ["x"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in + emit_set emit_init "r" (); - assert (get fp "x" = Some ()); - assert (get fp "y" = None); + assert (get_opt fp "x" = Some ()); + assert (get_opt fp "y" = None); assert (length fp = 3); let added = ref [] in let removed = ref [] in subscribe (function - | Set (k, ()) -> added := k :: !added - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> - match v_opt with - | Some () -> added := k :: !added - | None -> removed := k :: !removed) + (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed) entries) fp; - emit_edges (Set ("s", ["y"])); + emit_edge_set emit_edges "s" ["y"]; Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) (String.concat ", " !added); (* x should remain reachable; it must not be emitted as removed. *) - assert (get fp "x" = Some ()); - assert (get fp "y" = Some ()); + assert (get_opt fp "x" = Some ()); + assert (get_opt fp "y" = Some ()); assert (length fp = 4); assert (not (List.mem "x" !removed)); assert (List.mem "y" !added); diff --git a/analysis/reactive/test/FlatMapTest.ml b/analysis/reactive/test/FlatMapTest.ml index b9d2050469..6dfe5870ce 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/FlatMapTest.ml @@ -8,43 +8,46 @@ let test_flatmap_basic () = Printf.printf "=== Test: flatMap basic ===\n"; (* Create a simple source collection *) - let source, emit = source ~name:"source" () in + let source, emit = Source.create ~name:"source" () in (* Create derived collection via flatMap *) let derived = - flatMap ~name:"derived" source - ~f:(fun key value -> - [(key * 10, value); ((key * 10) + 1, value); ((key * 10) + 2, value)]) + FlatMap.create ~name:"derived" source + ~f:(fun key value wave -> + let key = Stable.to_linear_value key in + StableWave.push wave (Stable.int (key * 10)) value; + StableWave.push wave (Stable.int ((key * 10) + 1)) value; + StableWave.push wave (Stable.int ((key * 10) + 2)) value) () in (* Add entry -> derived should have 3 entries *) - emit (Set (1, "a")); - Printf.printf "After Set(1, 'a'): derived has %d entries\n" (length derived); + emit_set emit 1 "a"; + Printf.printf "After set (1, 'a'): derived has %d entries\n" (length derived); assert (length derived = 3); - assert (get source 1 = Some "a"); + assert (get_opt source 1 = Some "a"); (* Check source was updated *) - assert (get derived 10 = Some "a"); - assert (get derived 11 = Some "a"); - assert (get derived 12 = Some "a"); + assert (get_opt derived 10 = Some "a"); + assert (get_opt derived 11 = Some "a"); + assert (get_opt derived 12 = Some "a"); (* Add another entry *) - emit (Set (2, "b")); - Printf.printf "After Set(2, 'b'): derived has %d entries\n" (length derived); + emit_set emit 2 "b"; + Printf.printf "After set (2, 'b'): derived has %d entries\n" (length derived); assert (length derived = 6); (* Update entry *) - emit (Set (1, "A")); - Printf.printf "After Set(1, 'A'): derived has %d entries\n" (length derived); - assert (get derived 10 = Some "A"); + emit_set emit 1 "A"; + Printf.printf "After set (1, 'A'): derived has %d entries\n" (length derived); + assert (get_opt derived 10 = Some "A"); assert (length derived = 6); - (* Remove entry *) - emit (Remove 1); + (* remove entry *) + emit_remove emit 1; Printf.printf "After Remove(1): derived has %d entries\n" (length derived); assert (length derived = 3); - assert (get derived 10 = None); - assert (get derived 20 = Some "b"); + assert (get_opt derived 10 = None); + assert (get_opt derived 20 = Some "b"); Printf.printf "PASSED\n\n" @@ -52,32 +55,36 @@ let test_flatmap_with_merge () = reset (); Printf.printf "=== Test: flatMap with merge ===\n"; - let source, emit = source ~name:"source" () in + let source, emit = Source.create ~name:"source" () in (* Create derived with merge *) let derived = - flatMap ~name:"derived" source - ~f:(fun _key values -> [(0, values)]) (* all contribute to key 0 *) - ~merge:IntSet.union () + FlatMap.create ~name:"derived" source + ~f:(fun _key values wave -> StableWave.push wave (Stable.int 0) values) + (* all contribute to key 0 *) + ~merge:(fun a b -> + Stable.unsafe_of_value + (IntSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Source 1 contributes {1, 2} *) - emit (Set (1, IntSet.of_list [1; 2])); - let v = get derived 0 |> Option.get in + emit_set emit 1 (IntSet.of_list [1; 2]); + let v = get_opt derived 0 |> Option.get in Printf.printf "After source 1: {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [1; 2])); (* Source 2 contributes {3, 4} -> should merge *) - emit (Set (2, IntSet.of_list [3; 4])); - let v = get derived 0 |> Option.get in + emit_set emit 2 (IntSet.of_list [3; 4]); + let v = get_opt derived 0 |> Option.get in Printf.printf "After source 2: {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [1; 2; 3; 4])); - (* Remove source 1 *) - emit (Remove 1); - let v = get derived 0 |> Option.get in + (* remove source 1 *) + emit_remove emit 1; + let v = get_opt derived 0 |> Option.get in Printf.printf "After remove 1: {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [3; 4])); @@ -89,42 +96,52 @@ let test_composition () = Printf.printf "=== Test: composition (flatMap chain) ===\n"; (* Source: file -> list of items *) - let source, emit = source ~name:"source" () in + let source, emit = Source.create ~name:"source" () in (* First flatMap: file -> items *) let items = - flatMap ~name:"items" source - ~f:(fun path items -> - List.mapi (fun i item -> (Printf.sprintf "%s:%d" path i, item)) items) + FlatMap.create ~name:"items" source + ~f:(fun path items wave -> + let path = Stable.to_linear_value path in + List.iteri + (fun i item -> + StableWave.push wave + (Stable.unsafe_of_value (Printf.sprintf "%s:%d" path i)) + (Stable.unsafe_of_value item)) + (Stable.to_linear_value items)) () in (* Second flatMap: item -> chars *) let chars = - flatMap ~name:"chars" items - ~f:(fun key value -> - String.to_seq value - |> Seq.mapi (fun i c -> (Printf.sprintf "%s:%d" key i, c)) - |> List.of_seq) + FlatMap.create ~name:"chars" items + ~f:(fun key value wave -> + let key = Stable.to_linear_value key in + String.iteri + (fun i c -> + StableWave.push wave + (Stable.unsafe_of_value (Printf.sprintf "%s:%d" key i)) + (Stable.unsafe_of_value c)) + (Stable.to_linear_value value)) () in (* Add file with 2 items *) - emit (Set ("file1", ["ab"; "cd"])); + emit_set emit "file1" ["ab"; "cd"]; Printf.printf "After file1: items=%d, chars=%d\n" (length items) (length chars); assert (length items = 2); assert (length chars = 4); (* Add another file *) - emit (Set ("file2", ["xyz"])); + emit_set emit "file2" ["xyz"]; Printf.printf "After file2: items=%d, chars=%d\n" (length items) (length chars); assert (length items = 3); assert (length chars = 7); (* Update file1 *) - emit (Set ("file1", ["a"])); + emit_set emit "file1" ["a"]; Printf.printf "After update file1: items=%d, chars=%d\n" (length items) (length chars); assert (length items = 2); @@ -139,22 +156,25 @@ let test_flatmap_on_existing_data () = Printf.printf "=== Test: flatMap on collection with existing data ===\n"; (* Create source and add data before creating flatMap *) - let source, emit = source ~name:"source" () in - emit (Set (1, "a")); - emit (Set (2, "b")); + let source, emit = Source.create ~name:"source" () in + emit_set emit 1 "a"; + emit_set emit 2 "b"; Printf.printf "Source has %d entries before flatMap\n" (length source); (* Create flatMap AFTER source has data *) let derived = - flatMap ~name:"derived" source ~f:(fun k v -> [(k * 10, v)]) () + FlatMap.create ~name:"derived" source + ~f:(fun k v wave -> + StableWave.push wave (Stable.int (Stable.to_linear_value k * 10)) v) + () in (* Check derived has existing data *) Printf.printf "Derived has %d entries (expected 2)\n" (length derived); assert (length derived = 2); - assert (get derived 10 = Some "a"); - assert (get derived 20 = Some "b"); + assert (get_opt derived 10 = Some "a"); + assert (get_opt derived 20 = Some "b"); Printf.printf "PASSED\n\n" diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index 3954075877..1b991fc78a 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -1,6 +1,7 @@ (** Tests for glitch-free semantics with the accumulate-then-propagate scheduler *) open Reactive +open TestHelpers type file_data = {refs: (string * string) list; decl_positions: string list} (** Type for file data *) @@ -15,19 +16,21 @@ type full_file_data = { (** Track all deltas received *) let track_deltas c = let received = ref [] in - c.subscribe (fun d -> received := d :: !received); + c.subscribe (fun wave -> + let rev_entries = ref [] in + StableWave.iter wave (fun k mv -> + let k = Stable.to_linear_value k in + let mv = Stable.to_linear_value mv in + rev_entries := (k, mv) :: !rev_entries); + received := List.rev !rev_entries :: !received); received (** Count adds and removes *) let count_delta = function - | Set _ -> (1, 0) - | Remove _ -> (0, 1) - | Batch entries -> + | entries -> List.fold_left - (fun (a, r) (_, v_opt) -> - match v_opt with - | Some _ -> (a + 1, r) - | None -> (a, r + 1)) + (fun (a, r) (_, mv) -> + if Maybe.is_some mv then (a + 1, r) else (a, r + 1)) (0, 0) entries let sum_deltas deltas = @@ -42,39 +45,50 @@ let test_same_source_anti_join () = reset (); Printf.printf "=== Test: same source anti-join ===\n"; - let src, emit = source ~name:"source" () in + let src, emit = Source.create ~name:"source" () in let refs = - flatMap ~name:"refs" src ~f:(fun _file (data : file_data) -> data.refs) () + FlatMap.create ~name:"refs" src + ~f:(fun _file data wave -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) + data.refs) + () in let decls = - flatMap ~name:"decls" src - ~f:(fun _file (data : file_data) -> - List.map (fun pos -> (pos, ())) data.decl_positions) + FlatMap.create ~name:"decls" src + ~f:(fun _file data wave -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun pos -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit) + data.decl_positions) () in let external_refs = - join ~name:"external_refs" refs decls + Join.create ~name:"external_refs" refs decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> - match decl_opt with - | Some () -> [] - | None -> [(posTo, ())]) - ~merge:(fun () () -> ()) + ~f:(fun _posFrom posTo decl_mb wave -> + if not (Maybe.is_some decl_mb) then + StableWave.push wave + (Stable.unsafe_of_value (Stable.to_linear_value posTo)) + Stable.unit) + ~merge:(fun _l _r -> Stable.unit) () in let deltas = track_deltas external_refs in - emit - (Batch - [ - set "file1" - {refs = [("A", "X"); ("B", "Y")]; decl_positions = ["A"; "B"]}; - set "file2" {refs = [("C", "Z")]; decl_positions = []}; - ]); + emit_sets emit + [ + ("file1", {refs = [("A", "X"); ("B", "Y")]; decl_positions = ["A"; "B"]}); + ("file2", {refs = [("C", "Z")]; decl_positions = []}); + ]; let adds, removes = sum_deltas !deltas in Printf.printf "adds=%d, removes=%d, len=%d\n" adds removes @@ -89,57 +103,75 @@ let test_multi_level_union () = reset (); Printf.printf "=== Test: multi-level union ===\n"; - let src, emit = source ~name:"source" () in + let src, emit = Source.create ~name:"source" () in (* refs1: level 1 *) let refs1 = - flatMap ~name:"refs1" src - ~f:(fun _file (data : file_data) -> - List.filter (fun (k, _) -> String.length k > 0 && k.[0] = 'D') data.refs) + FlatMap.create ~name:"refs1" src + ~f:(fun _file data wave -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + if String.length k > 0 && k.[0] = 'D' then + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) + data.refs) () in (* intermediate: level 1 *) let intermediate = - flatMap ~name:"intermediate" src - ~f:(fun _file (data : file_data) -> - List.filter (fun (k, _) -> String.length k > 0 && k.[0] = 'I') data.refs) + FlatMap.create ~name:"intermediate" src + ~f:(fun _file data wave -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + if String.length k > 0 && k.[0] = 'I' then + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) + data.refs) () in (* refs2: level 2 *) - let refs2 = flatMap ~name:"refs2" intermediate ~f:(fun k v -> [(k, v)]) () in + let refs2 = + FlatMap.create ~name:"refs2" intermediate + ~f:(fun k v wave -> StableWave.push wave k v) + () + in (* decls: level 1 *) let decls = - flatMap ~name:"decls" src - ~f:(fun _file (data : file_data) -> - List.map (fun pos -> (pos, ())) data.decl_positions) + FlatMap.create ~name:"decls" src + ~f:(fun _file data wave -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun pos -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit) + data.decl_positions) () in (* all_refs: union at level 3 *) - let all_refs = union ~name:"all_refs" refs1 refs2 () in + let all_refs = Union.create ~name:"all_refs" refs1 refs2 () in (* external_refs: join at level 4 *) let external_refs = - join ~name:"external_refs" all_refs decls + Join.create ~name:"external_refs" all_refs decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> - match decl_opt with - | Some () -> [] - | None -> [(posTo, ())]) - ~merge:(fun () () -> ()) + ~f:(fun _posFrom posTo decl_mb wave -> + if not (Maybe.is_some decl_mb) then + StableWave.push wave + (Stable.unsafe_of_value (Stable.to_linear_value posTo)) + Stable.unit) + ~merge:(fun _l _r -> Stable.unit) () in let deltas = track_deltas external_refs in - emit - (Batch - [ - set "file1" {refs = [("D1", "X"); ("I1", "Y")]; decl_positions = ["D1"]}; - ]); + emit_set emit "file1" + {refs = [("D1", "X"); ("I1", "Y")]; decl_positions = ["D1"]}; let adds, removes = sum_deltas !deltas in Printf.printf "adds=%d, removes=%d, len=%d\n" adds removes @@ -154,85 +186,99 @@ let test_real_pipeline_simulation () = reset (); Printf.printf "=== Test: real pipeline simulation ===\n"; - let src, emit = source ~name:"source" () in + let src, emit = Source.create ~name:"source" () in (* decls: level 1 *) let decls = - flatMap ~name:"decls" src - ~f:(fun _file (data : full_file_data) -> - List.map (fun pos -> (pos, ())) data.full_decls) + FlatMap.create ~name:"decls" src + ~f:(fun _file data wave -> + let data : full_file_data = Stable.to_linear_value data in + List.iter + (fun pos -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit) + data.full_decls) () in (* merged_value_refs: level 1 *) let merged_value_refs = - flatMap ~name:"merged_value_refs" src - ~f:(fun _file (data : full_file_data) -> data.value_refs) + FlatMap.create ~name:"merged_value_refs" src + ~f:(fun _file data wave -> + let data : full_file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) + data.value_refs) () in (* exception_refs_raw: level 1 *) let exception_refs_raw = - flatMap ~name:"exception_refs_raw" src - ~f:(fun _file (data : full_file_data) -> data.exception_refs) + FlatMap.create ~name:"exception_refs_raw" src + ~f:(fun _file data wave -> + let data : full_file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) + data.exception_refs) () in (* exception_decls: level 2 *) let exception_decls = - flatMap ~name:"exception_decls" decls - ~f:(fun pos () -> - if String.length pos > 0 && pos.[0] = 'E' then [(pos, ())] else []) + FlatMap.create ~name:"exception_decls" decls + ~f:(fun pos _unit wave -> + let pos_v = Stable.to_linear_value pos in + if String.length pos_v > 0 && pos_v.[0] = 'E' then + StableWave.push wave pos Stable.unit) () in (* resolved_exception_refs: join at level 3 *) let resolved_exception_refs = - join ~name:"resolved_exception_refs" exception_refs_raw exception_decls + Join.create ~name:"resolved_exception_refs" exception_refs_raw + exception_decls ~key_of:(fun path _loc -> path) - ~f:(fun path loc decl_opt -> - match decl_opt with - | Some () -> [(path, loc)] - | None -> []) + ~f:(fun path loc decl_mb wave -> + if Maybe.is_some decl_mb then StableWave.push wave path loc) () in (* resolved_refs_from: level 4 *) let resolved_refs_from = - flatMap ~name:"resolved_refs_from" resolved_exception_refs - ~f:(fun posTo posFrom -> [(posFrom, posTo)]) + FlatMap.create ~name:"resolved_refs_from" resolved_exception_refs + ~f:(fun posTo posFrom wave -> StableWave.push wave posFrom posTo) () in (* value_refs_from: union at level 5 *) let value_refs_from = - union ~name:"value_refs_from" merged_value_refs resolved_refs_from () + Union.create ~name:"value_refs_from" merged_value_refs resolved_refs_from () in (* external_value_refs: join at level 6 *) let external_value_refs = - join ~name:"external_value_refs" value_refs_from decls + Join.create ~name:"external_value_refs" value_refs_from decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> - match decl_opt with - | Some () -> [] - | None -> [(posTo, ())]) - ~merge:(fun () () -> ()) + ~f:(fun _posFrom posTo decl_mb wave -> + if not (Maybe.is_some decl_mb) then + StableWave.push wave + (Stable.unsafe_of_value (Stable.to_linear_value posTo)) + Stable.unit) + ~merge:(fun _l _r -> Stable.unit) () in let deltas = track_deltas external_value_refs in - emit - (Batch - [ - set "file1" - { - value_refs = [("A", "X")]; - exception_refs = [("E1", "Y")]; - full_decls = ["A"; "E1"]; - }; - ]); + emit_set emit "file1" + { + value_refs = [("A", "X")]; + exception_refs = [("E1", "Y")]; + full_decls = ["A"; "E1"]; + }; let _adds, removes = sum_deltas !deltas in Printf.printf "removes=%d, len=%d\n" removes (length external_value_refs); @@ -245,30 +291,31 @@ let test_separate_sources () = reset (); Printf.printf "=== Test: separate sources (removals expected) ===\n"; - let refs_src, emit_refs = source ~name:"refs_source" () in - let decls_src, emit_decls = source ~name:"decls_source" () in + let refs_src, emit_refs = Source.create ~name:"refs_source" () in + let decls_src, emit_decls = Source.create ~name:"decls_source" () in let external_refs = - join ~name:"external_refs" refs_src decls_src + Join.create ~name:"external_refs" refs_src decls_src ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> - match decl_opt with - | Some () -> [] - | None -> [(posTo, ())]) - ~merge:(fun () () -> ()) + ~f:(fun _posFrom posTo decl_mb wave -> + if not (Maybe.is_some decl_mb) then + StableWave.push wave + (Stable.unsafe_of_value (Stable.to_linear_value posTo)) + Stable.unit) + ~merge:(fun _l _r -> Stable.unit) () in let deltas = track_deltas external_refs in (* Refs arrive first *) - emit_refs (Batch [set "A" "X"; set "B" "Y"; set "C" "Z"]); + emit_sets emit_refs [("A", "X"); ("B", "Y"); ("C", "Z")]; let adds1, _ = sum_deltas !deltas in Printf.printf "After refs: adds=%d, len=%d\n" adds1 (length external_refs); (* Decls arrive second - causes removals *) - emit_decls (Batch [set "A" (); set "B" ()]); + emit_sets emit_decls [("A", ()); ("B", ())]; let adds2, removes2 = sum_deltas !deltas in Printf.printf "After decls: adds=%d, removes=%d, len=%d\n" adds2 removes2 diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/IntegrationTest.ml index 428a1b2f8e..b90dd28bd1 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -8,24 +8,32 @@ let test_file_collection () = Printf.printf "=== Test: File collection simulation ===\n"; (* Simulate file processing with regular sources *) - let files, emit_file = source ~name:"files" () in + let files, emit_file = Source.create ~name:"files" () in (* file_a: hello(2), world(1) *) (* file_b: hello(1), foo(1) *) (* First flatMap: aggregate word counts across files with merge *) let word_counts = - flatMap ~name:"word_counts" files - ~f:(fun _path counts -> StringMap.bindings counts) + FlatMap.create ~name:"word_counts" files + ~f:(fun _path counts wave -> + StringMap.iter + (fun k v -> + StableWave.push wave (Stable.unsafe_of_value k) (Stable.int v)) + (Stable.to_linear_value counts)) (* Each file contributes its word counts *) - ~merge:( + ) (* Sum counts from multiple files *) + ~merge:(fun a b -> + Stable.int (Stable.to_linear_value a + Stable.to_linear_value b)) + (* Sum counts from multiple files *) () in (* Second flatMap: filter to words with count >= 2 *) let frequent_words = - flatMap ~name:"frequent_words" word_counts - ~f:(fun word count -> if count >= 2 then [(word, count)] else []) + FlatMap.create ~name:"frequent_words" word_counts + ~f:(fun word count wave -> + if Stable.to_linear_value count >= 2 then + StableWave.push wave word count) () in @@ -36,47 +44,67 @@ let test_file_collection () = let counts_b = StringMap.empty |> StringMap.add "hello" 1 |> StringMap.add "foo" 1 in - emit_file (Set ("file_a", counts_a)); - emit_file (Set ("file_b", counts_b)); + emit_set emit_file "file_a" counts_a; + emit_set emit_file "file_b" counts_b; Printf.printf "Word counts:\n"; - iter (fun word count -> Printf.printf " %s: %d\n" word count) word_counts; + iter + (fun word count -> + Printf.printf " %s: %d\n" + (Stable.to_linear_value word) + (Stable.to_linear_value count)) + word_counts; Printf.printf "Frequent words (count >= 2):\n"; - iter (fun word count -> Printf.printf " %s: %d\n" word count) frequent_words; + iter + (fun word count -> + Printf.printf " %s: %d\n" + (Stable.to_linear_value word) + (Stable.to_linear_value count)) + frequent_words; (* Verify: hello=3 (2 from a + 1 from b), world=1, foo=1 *) - assert (get word_counts "hello" = Some 3); - assert (get word_counts "world" = Some 1); - assert (get word_counts "foo" = Some 1); + assert (get_opt word_counts "hello" = Some 3); + assert (get_opt word_counts "world" = Some 1); + assert (get_opt word_counts "foo" = Some 1); assert (length word_counts = 3); (* Verify frequent: only "hello" with count 3 *) assert (length frequent_words = 1); - assert (get frequent_words "hello" = Some 3); + assert (get_opt frequent_words "hello" = Some 3); (* Modify file_a: now hello(1), world(2) *) Printf.printf "\nModifying file_a...\n"; let counts_a' = StringMap.empty |> StringMap.add "hello" 1 |> StringMap.add "world" 2 in - emit_file (Set ("file_a", counts_a')); + emit_set emit_file "file_a" counts_a'; Printf.printf "Word counts after modification:\n"; - iter (fun word count -> Printf.printf " %s: %d\n" word count) word_counts; + iter + (fun word count -> + Printf.printf " %s: %d\n" + (Stable.to_linear_value word) + (Stable.to_linear_value count)) + word_counts; Printf.printf "Frequent words after modification:\n"; - iter (fun word count -> Printf.printf " %s: %d\n" word count) frequent_words; + iter + (fun word count -> + Printf.printf " %s: %d\n" + (Stable.to_linear_value word) + (Stable.to_linear_value count)) + frequent_words; (* Verify: hello=2 (1 from a + 1 from b), world=2, foo=1 *) - assert (get word_counts "hello" = Some 2); - assert (get word_counts "world" = Some 2); - assert (get word_counts "foo" = Some 1); + assert (get_opt word_counts "hello" = Some 2); + assert (get_opt word_counts "world" = Some 2); + assert (get_opt word_counts "foo" = Some 1); (* Verify frequent: hello=2, world=2 *) assert (length frequent_words = 2); - assert (get frequent_words "hello" = Some 2); - assert (get frequent_words "world" = Some 2); + assert (get_opt frequent_words "hello" = Some 2); + assert (get_opt frequent_words "world" = Some 2); Printf.printf "PASSED\n\n" diff --git a/analysis/reactive/test/JoinTest.ml b/analysis/reactive/test/JoinTest.ml index 70c4eb6136..2732e6863f 100644 --- a/analysis/reactive/test/JoinTest.ml +++ b/analysis/reactive/test/JoinTest.ml @@ -1,27 +1,28 @@ (** Join combinator tests *) open Reactive +open TestHelpers let test_join () = reset (); Printf.printf "=== Test: join (reactive lookup/join) ===\n"; (* Left collection: exception refs (path -> loc_from) *) - let left, emit_left = source ~name:"left" () in + let left, emit_left = Source.create ~name:"left" () in (* Right collection: decl index (path -> decl_pos) *) - let right, emit_right = source ~name:"right" () in + let right, emit_right = Source.create ~name:"right" () in (* Join: for each (path, loc_from) in left, look up path in right *) let joined = - join ~name:"joined" left right + Join.create ~name:"joined" left right ~key_of:(fun path _loc_from -> path) - ~f:(fun _path loc_from decl_pos_opt -> - match decl_pos_opt with - | Some decl_pos -> - (* Produce (decl_pos, loc_from) pairs *) - [(decl_pos, loc_from)] - | None -> []) + ~f:(fun _path loc_from decl_pos_mb wave -> + if Maybe.is_some decl_pos_mb then + let decl_pos = + Stable.to_linear_value (Maybe.unsafe_get decl_pos_mb) + in + StableWave.push wave (Stable.int decl_pos) loc_from) () in @@ -29,47 +30,47 @@ let test_join () = assert (length joined = 0); (* Add declaration at path "A" with pos 100 *) - emit_right (Set ("A", 100)); - Printf.printf "After right Set(A, 100): joined=%d\n" (length joined); + emit_set emit_right "A" 100; + Printf.printf "After right set (A, 100): joined=%d\n" (length joined); assert (length joined = 0); (* No left entries yet *) (* Add exception ref at path "A" from loc 1 *) - emit_left (Set ("A", 1)); - Printf.printf "After left Set(A, 1): joined=%d\n" (length joined); + emit_set emit_left "A" 1; + Printf.printf "After left set (A, 1): joined=%d\n" (length joined); assert (length joined = 1); - assert (get joined 100 = Some 1); + assert (get_opt joined 100 = Some 1); (* decl_pos 100 -> loc_from 1 *) (* Add another exception ref at path "B" (no matching decl) *) - emit_left (Set ("B", 2)); - Printf.printf "After left Set(B, 2): joined=%d (B has no decl)\n" + emit_set emit_left "B" 2; + Printf.printf "After left set (B, 2): joined=%d (B has no decl)\n" (length joined); assert (length joined = 1); (* Add declaration for path "B" *) - emit_right (Set ("B", 200)); - Printf.printf "After right Set(B, 200): joined=%d\n" (length joined); + emit_set emit_right "B" 200; + Printf.printf "After right set (B, 200): joined=%d\n" (length joined); assert (length joined = 2); - assert (get joined 200 = Some 2); + assert (get_opt joined 200 = Some 2); (* Update right: change B's decl_pos *) - emit_right (Set ("B", 201)); - Printf.printf "After right Set(B, 201): joined=%d\n" (length joined); + emit_set emit_right "B" 201; + Printf.printf "After right set (B, 201): joined=%d\n" (length joined); assert (length joined = 2); - assert (get joined 200 = None); + assert (get_opt joined 200 = None); (* Old key gone *) - assert (get joined 201 = Some 2); + assert (get_opt joined 201 = Some 2); (* New key has the value *) - (* Remove left entry A *) - emit_left (Remove "A"); + (* remove left entry A *) + emit_remove emit_left "A"; Printf.printf "After left Remove(A): joined=%d\n" (length joined); assert (length joined = 1); - assert (get joined 100 = None); + assert (get_opt joined 100 = None); Printf.printf "PASSED\n\n" @@ -78,40 +79,41 @@ let test_join_with_merge () = Printf.printf "=== Test: join with merge ===\n"; (* Multiple left entries can map to same right key *) - let left, emit_left = source ~name:"left" () in - let right, emit_right = source ~name:"right" () in + let left, emit_left = Source.create ~name:"left" () in + let right, emit_right = Source.create ~name:"right" () in (* Join with merge: all entries produce to key 0 *) let joined = - join ~name:"joined" left right + Join.create ~name:"joined" left right ~key_of:(fun _id path -> path) (* Look up by path *) - ~f:(fun _id _path value_opt -> - match value_opt with - | Some v -> [(0, v)] (* All contribute to key 0 *) - | None -> []) - ~merge:( + ) (* Sum values *) + ~f:(fun _id _path value_mb wave -> + if Maybe.is_some value_mb then + StableWave.push wave (Stable.int 0) (Maybe.unsafe_get value_mb)) + ~merge:(fun l r -> + Stable.int (Stable.to_linear_value l + Stable.to_linear_value r)) + (* Sum values *) () in - emit_right (Set ("X", 10)); - emit_left (Set (1, "X")); - emit_left (Set (2, "X")); + emit_set emit_right "X" 10; + emit_set emit_left 1 "X"; + emit_set emit_left 2 "X"; Printf.printf "Two entries looking up X (value 10): sum=%d\n" - (get joined 0 |> Option.value ~default:0); - assert (get joined 0 = Some 20); + (get_opt joined 0 |> Option.value ~default:0); + assert (get_opt joined 0 = Some 20); (* 10 + 10 *) - emit_right (Set ("X", 5)); + emit_set emit_right "X" 5; Printf.printf "After right changes to 5: sum=%d\n" - (get joined 0 |> Option.value ~default:0); - assert (get joined 0 = Some 10); + (get_opt joined 0 |> Option.value ~default:0); + assert (get_opt joined 0 = Some 10); (* 5 + 5 *) - emit_left (Remove 1); + emit_remove emit_left 1; Printf.printf "After removing one left entry: sum=%d\n" - (get joined 0 |> Option.value ~default:0); - assert (get joined 0 = Some 5); + (get_opt joined 0 |> Option.value ~default:0); + assert (get_opt joined 0 = Some 5); (* Only one left *) Printf.printf "PASSED\n\n" diff --git a/analysis/reactive/test/ReactiveTest.ml b/analysis/reactive/test/ReactiveTest.ml index e94162f2b1..388447b0f3 100644 --- a/analysis/reactive/test/ReactiveTest.ml +++ b/analysis/reactive/test/ReactiveTest.ml @@ -10,4 +10,5 @@ let () = BatchTest.run_all (); IntegrationTest.run_all (); GlitchFreeTest.run_all (); + AllocTest.run_all (); Printf.printf "\nAll tests passed!\n" diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 54067172fe..aa6263ee3c 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -2,33 +2,102 @@ open Reactive -(** {1 Compatibility helpers} *) +(** {1 Wave-based emit helpers} *) -(* V2's emit takes deltas, not tuples. These helpers adapt tuple-style calls. *) -let[@warning "-32"] emit_kv emit (k, v_opt) = - match v_opt with - | Some v -> emit (Set (k, v)) - | None -> emit (Remove k) +(** Shared scratch wave for test emit helpers. + Tests are single-threaded so one global wave is safe. + The wave stores [Obj.t] internally, so a single concrete instance + can be safely reused at any type via [Obj.magic]. *) +let scratch_wave : (int, int) StableWave.t = StableWave.create () -(* subscribe takes collection first in V2, but we want handler first for compatibility *) -let subscribe handler t = t.subscribe handler +let wave () : ('k, 'v) StableWave.t = Obj.magic scratch_wave + +(** Emit a single set entry *) +let emit_set emit k v = + let w = wave () in + StableWave.clear w; + StableWave.push w (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v)); + emit w + +(** Emit a single edge-set entry, converting the successor list to the + explicit stable-list type. *) +let emit_edge_set emit k vs = + let w = wave () in + StableWave.clear w; + StableWave.push w (Stable.unsafe_of_value k) + (StableList.maybe_to_stable (Maybe.some (StableList.unsafe_of_list vs))); + emit w + +(** Emit a single remove entry *) +let emit_remove emit k = + let w = wave () in + StableWave.clear w; + StableWave.push w (Stable.unsafe_of_value k) Maybe.none_stable; + emit w + +(** Emit a batch of (key, value) set entries *) +let emit_sets emit entries = + let w = wave () in + StableWave.clear w; + List.iter + (fun (k, v) -> + StableWave.push w (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v))) + entries; + emit w + +(** Emit a batch of (key, value option) entries — for mixed set/remove batches *) +let emit_batch emit entries = + let w = wave () in + StableWave.clear w; + List.iter + (fun (k, v_opt) -> + match v_opt with + | Some v -> + StableWave.push w (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v)) + | None -> StableWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) + entries; + emit w -(* emit_batch: emit a batch delta to a source *) -let emit_batch entries emit_fn = emit_fn (Batch entries) +(** Emit a batch of edge entries using the explicit stable-list type. *) +let emit_edge_batch emit entries = + let w = wave () in + StableWave.clear w; + List.iter + (fun (k, vs_opt) -> + match vs_opt with + | Some vs -> + StableWave.push w (Stable.unsafe_of_value k) + (StableList.maybe_to_stable + (Maybe.some (StableList.unsafe_of_list vs))) + | None -> StableWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) + entries; + emit w + +(** {1 Compatibility helpers} *) + +(* subscribe takes collection first in V2, but we want handler first for compatibility *) +let subscribe handler t = + t.subscribe (fun wave -> + let rev_entries = ref [] in + StableWave.iter wave (fun k mv -> + let k = Stable.to_linear_value k in + let mv = Stable.to_linear_value mv in + rev_entries := (k, mv) :: !rev_entries); + handler (List.rev !rev_entries)) (* Helper to track added/removed across all delta types *) let[@warning "-32"] track_changes () = let added = ref [] in let removed = ref [] in let handler = function - | Set (k, _) -> added := k :: !added - | Remove k -> removed := k :: !removed - | Batch entries -> + | entries -> List.iter - (fun (k, v_opt) -> - match v_opt with - | Some _ -> added := k :: !added - | None -> removed := k :: !removed) + (fun (k, mv) -> + if Maybe.is_some mv then added := k :: !added + else removed := k :: !removed) entries in (added, removed, handler) @@ -51,6 +120,16 @@ let[@warning "-32"] write_lines path lines = List.iter (fun line -> output_string oc (line ^ "\n")) lines; close_out oc +(** {1 Maybe/option helpers} *) + +(** Convert [get] result to option for test assertions. + Wraps the key as [Stable.t] and unwraps the result for convenience. *) +let get_opt t k = + let r = get t (Stable.unsafe_of_value k) in + match Maybe.to_option r with + | Some v -> Some (Stable.to_linear_value v) + | None -> None + (** {1 Common set modules} *) module IntSet = Set.Make (Int) diff --git a/analysis/reactive/test/UnionTest.ml b/analysis/reactive/test/UnionTest.ml index c532180389..616b36bdb1 100644 --- a/analysis/reactive/test/UnionTest.ml +++ b/analysis/reactive/test/UnionTest.ml @@ -8,53 +8,53 @@ let test_union_basic () = Printf.printf "=== Test: union basic ===\n"; (* Left collection *) - let left, emit_left = source ~name:"left" () in + let left, emit_left = Source.create ~name:"left" () in (* Right collection *) - let right, emit_right = source ~name:"right" () in + let right, emit_right = Source.create ~name:"right" () in (* Create union without merge (right takes precedence) *) - let combined = union ~name:"combined" left right () in + let combined = Union.create ~name:"combined" left right () in (* Initially empty *) assert (length combined = 0); (* Add to left *) - emit_left (Set ("a", 1)); - Printf.printf "After left Set(a, 1): combined=%d\n" (length combined); + emit_set emit_left "a" 1; + Printf.printf "After left set (a, 1): combined=%d\n" (length combined); assert (length combined = 1); - assert (get combined "a" = Some 1); + assert (get_opt combined "a" = Some 1); (* Add different key to right *) - emit_right (Set ("b", 2)); - Printf.printf "After right Set(b, 2): combined=%d\n" (length combined); + emit_set emit_right "b" 2; + Printf.printf "After right set (b, 2): combined=%d\n" (length combined); assert (length combined = 2); - assert (get combined "a" = Some 1); - assert (get combined "b" = Some 2); + assert (get_opt combined "a" = Some 1); + assert (get_opt combined "b" = Some 2); (* Add same key to right (should override left) *) - emit_right (Set ("a", 10)); - Printf.printf "After right Set(a, 10): combined a=%d\n" - (get combined "a" |> Option.value ~default:(-1)); + emit_set emit_right "a" 10; + Printf.printf "After right set (a, 10): combined a=%d\n" + (get_opt combined "a" |> Option.value ~default:(-1)); assert (length combined = 2); - assert (get combined "a" = Some 10); + assert (get_opt combined "a" = Some 10); (* Right takes precedence *) - (* Remove from right (left value should show through) *) - emit_right (Remove "a"); + (* remove from right (left value should show through) *) + emit_remove emit_right "a"; Printf.printf "After right Remove(a): combined a=%d\n" - (get combined "a" |> Option.value ~default:(-1)); - assert (get combined "a" = Some 1); + (get_opt combined "a" |> Option.value ~default:(-1)); + assert (get_opt combined "a" = Some 1); (* Left shows through *) - (* Remove from left *) - emit_left (Remove "a"); + (* remove from left *) + emit_remove emit_left "a"; Printf.printf "After left Remove(a): combined=%d\n" (length combined); assert (length combined = 1); - assert (get combined "a" = None); - assert (get combined "b" = Some 2); + assert (get_opt combined "a" = None); + assert (get_opt combined "b" = Some 2); Printf.printf "PASSED\n\n" @@ -63,38 +63,44 @@ let test_union_with_merge () = Printf.printf "=== Test: union with merge ===\n"; (* Left collection *) - let left, emit_left = source ~name:"left" () in + let left, emit_left = Source.create ~name:"left" () in (* Right collection *) - let right, emit_right = source ~name:"right" () in + let right, emit_right = Source.create ~name:"right" () in (* Create union with set union as merge *) - let combined = union ~name:"combined" left right ~merge:IntSet.union () in + let combined = + Union.create ~name:"combined" left right + ~merge:(fun a b -> + Stable.unsafe_of_value + (IntSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () + in (* Add to left: key "x" -> {1, 2} *) - emit_left (Set ("x", IntSet.of_list [1; 2])); - let v = get combined "x" |> Option.get in - Printf.printf "After left Set(x, {1,2}): {%s}\n" + emit_set emit_left "x" (IntSet.of_list [1; 2]); + let v = get_opt combined "x" |> Option.get in + Printf.printf "After left set (x, {1,2}): {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [1; 2])); (* Add to right: key "x" -> {3, 4} (should merge) *) - emit_right (Set ("x", IntSet.of_list [3; 4])); - let v = get combined "x" |> Option.get in - Printf.printf "After right Set(x, {3,4}): {%s}\n" + emit_set emit_right "x" (IntSet.of_list [3; 4]); + let v = get_opt combined "x" |> Option.get in + Printf.printf "After right set (x, {3,4}): {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [1; 2; 3; 4])); (* Update left: key "x" -> {1, 5} *) - emit_left (Set ("x", IntSet.of_list [1; 5])); - let v = get combined "x" |> Option.get in + emit_set emit_left "x" (IntSet.of_list [1; 5]); + let v = get_opt combined "x" |> Option.get in Printf.printf "After left update to {1,5}: {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [1; 3; 4; 5])); - (* Remove right *) - emit_right (Remove "x"); - let v = get combined "x" |> Option.get in + (* remove right *) + emit_remove emit_right "x"; + let v = get_opt combined "x" |> Option.get in Printf.printf "After right Remove(x): {%s}\n" (IntSet.elements v |> List.map string_of_int |> String.concat ", "); assert (IntSet.equal v (IntSet.of_list [1; 5])); @@ -106,31 +112,56 @@ let test_union_existing_data () = Printf.printf "=== Test: union on collections with existing data ===\n"; (* Create collections with existing data *) - let left, emit_left = source ~name:"left" () in - emit_left (Set (1, "a")); - emit_left (Set (2, "b")); + let left, emit_left = Source.create ~name:"left" () in + emit_set emit_left 1 "a"; + emit_set emit_left 2 "b"; - let right, emit_right = source ~name:"right" () in - emit_right (Set (2, "B")); + let right, emit_right = Source.create ~name:"right" () in + emit_set emit_right 2 "B"; (* Overlaps with left *) - emit_right (Set (3, "c")); + emit_set emit_right 3 "c"; (* Create union after both have data *) - let combined = union ~name:"combined" left right () in + let combined = Union.create ~name:"combined" left right () in Printf.printf "Union has %d entries (expected 3)\n" (length combined); assert (length combined = 3); - assert (get combined 1 = Some "a"); + assert (get_opt combined 1 = Some "a"); (* Only in left *) - assert (get combined 2 = Some "B"); + assert (get_opt combined 2 = Some "B"); (* Right takes precedence *) - assert (get combined 3 = Some "c"); + assert (get_opt combined 3 = Some "c"); (* Only in right *) Printf.printf "PASSED\n\n" +let test_union_existing_data_with_non_idempotent_merge () = + reset (); + Printf.printf "=== Test: union existing data with non-idempotent merge ===\n"; + + (* Create collections with existing data *) + let left, emit_left = Source.create ~name:"left" () in + emit_set emit_left "only_left" 3; + + let right, _emit_right = Source.create ~name:"right" () in + + (* Create union after left already has data. + With merge = (+), a left-only key must stay 3, not 6. *) + let combined = + Union.create ~name:"combined" left right + ~merge:(fun a b -> + Stable.int (Stable.to_linear_value a + Stable.to_linear_value b)) + () + in + + assert (length combined = 1); + assert (get_opt combined "only_left" = Some 3); + + Printf.printf "PASSED\n\n" + let run_all () = Printf.printf "\n====== Union Tests ======\n\n"; test_union_basic (); test_union_with_merge (); - test_union_existing_data () + test_union_existing_data (); + test_union_existing_data_with_non_idempotent_merge () diff --git a/analysis/reactive/test/dune b/analysis/reactive/test/dune index cd8fe3ad9c..e7b34c15b9 100644 --- a/analysis/reactive/test/dune +++ b/analysis/reactive/test/dune @@ -10,5 +10,7 @@ FixpointIncrementalTest BatchTest IntegrationTest - GlitchFreeTest) + GlitchFreeTest + AllocMeasure + AllocTest) (libraries reactive)) diff --git a/analysis/reanalyze/src/AnnotationStore.ml b/analysis/reanalyze/src/AnnotationStore.ml index b34dbce8e7..95e1fa1758 100644 --- a/analysis/reanalyze/src/AnnotationStore.ml +++ b/analysis/reanalyze/src/AnnotationStore.ml @@ -15,20 +15,27 @@ let of_reactive reactive = Reactive reactive let is_annotated_dead t pos = match t with | Frozen ann -> FileAnnotations.is_annotated_dead ann pos - | Reactive reactive -> Reactive.get reactive pos = Some FileAnnotations.Dead + | Reactive reactive -> + let mb = Reactive.get reactive (Stable.unsafe_of_value pos) in + Maybe.is_some mb + && Stable.to_linear_value (Maybe.unsafe_get mb) = FileAnnotations.Dead let is_annotated_gentype_or_live t pos = match t with | Frozen ann -> FileAnnotations.is_annotated_gentype_or_live ann pos - | Reactive reactive -> ( - match Reactive.get reactive pos with - | Some (FileAnnotations.Live | FileAnnotations.GenType) -> true - | Some FileAnnotations.Dead | None -> false) + | Reactive reactive -> + let mb = Reactive.get reactive (Stable.unsafe_of_value pos) in + Maybe.is_some mb + && + let v = Stable.to_linear_value (Maybe.unsafe_get mb) in + v = FileAnnotations.Live || v = FileAnnotations.GenType let is_annotated_gentype_or_dead t pos = match t with | Frozen ann -> FileAnnotations.is_annotated_gentype_or_dead ann pos - | Reactive reactive -> ( - match Reactive.get reactive pos with - | Some (FileAnnotations.Dead | FileAnnotations.GenType) -> true - | Some FileAnnotations.Live | None -> false) + | Reactive reactive -> + let mb = Reactive.get reactive (Stable.unsafe_of_value pos) in + Maybe.is_some mb + && + let v = Stable.to_linear_value (Maybe.unsafe_get mb) in + v = FileAnnotations.Dead || v = FileAnnotations.GenType diff --git a/analysis/reanalyze/src/CrossFileItemsStore.ml b/analysis/reanalyze/src/CrossFileItemsStore.ml index 33e5a756d6..7bfbe9e6ab 100644 --- a/analysis/reanalyze/src/CrossFileItemsStore.ml +++ b/analysis/reanalyze/src/CrossFileItemsStore.ml @@ -17,7 +17,9 @@ let iter_optional_arg_calls t f = | Frozen cfi -> List.iter f cfi.CrossFileItems.optional_arg_calls | Reactive r -> Reactive.iter - (fun _path items -> List.iter f items.CrossFileItems.optional_arg_calls) + (fun _path items -> + let items = Stable.to_linear_value items in + List.iter f items.CrossFileItems.optional_arg_calls) r let iter_function_refs t f = @@ -25,7 +27,9 @@ let iter_function_refs t f = | Frozen cfi -> List.iter f cfi.CrossFileItems.function_refs | Reactive r -> Reactive.iter - (fun _path items -> List.iter f items.CrossFileItems.function_refs) + (fun _path items -> + let items = Stable.to_linear_value items in + List.iter f items.CrossFileItems.function_refs) r (** Compute optional args state from calls and function references. diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index a2434473c0..f89c1700a4 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -481,7 +481,9 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from let t0 = Unix.gettimeofday () in let debug = config.DceConfig.cli.debug in let transitive = config.DceConfig.run.transitive in - let is_live pos = Reactive.get live pos <> None in + let is_live pos = + Maybe.is_some (Reactive.get live (Stable.unsafe_of_value pos)) + in (* hasRefBelow uses on-demand search through value_refs_from *) let hasRefBelow = @@ -489,7 +491,9 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from | None -> fun _ -> false | Some refs_from -> make_hasRefBelow ~transitive ~iter_value_refs_from:(fun f -> - Reactive.iter f refs_from) + Reactive.iter + (fun k v -> f (Stable.to_linear_value k) (Stable.to_linear_value v)) + refs_from) in (* Process each declaration based on computed liveness *) @@ -522,7 +526,9 @@ let solveDeadReactive ~ann_store ~config ~decl_store ~value_refs_from (if debug then let live_reason : Liveness.live_reason option = if not is_live then None - else if Reactive.get roots pos <> None then + else if + Maybe.is_some (Reactive.get roots (Stable.unsafe_of_value pos)) + then if AnnotationStore.is_annotated_gentype_or_live ann_store pos then Some Liveness.Annotated else Some Liveness.ExternalRef diff --git a/analysis/reanalyze/src/DeclarationStore.ml b/analysis/reanalyze/src/DeclarationStore.ml index 7b0043c541..be7c646721 100644 --- a/analysis/reanalyze/src/DeclarationStore.ml +++ b/analysis/reanalyze/src/DeclarationStore.ml @@ -17,17 +17,34 @@ let of_reactive reactive = Reactive reactive let find_opt t pos = match t with | Frozen decls -> Declarations.find_opt decls pos - | Reactive reactive -> Reactive.get reactive pos + | Reactive reactive -> + let mb = Reactive.get reactive (Stable.unsafe_of_value pos) in + if Maybe.is_some mb then + Some (Stable.unsafe_to_nonlinear_value (Maybe.unsafe_get mb)) + else None let fold f t init = match t with | Frozen decls -> Declarations.fold f decls init | Reactive reactive -> let acc = ref init in - Reactive.iter (fun pos decl -> acc := f pos decl !acc) reactive; + Reactive.iter + (fun pos decl -> + acc := + f + (Stable.unsafe_to_nonlinear_value pos) + (Stable.unsafe_to_nonlinear_value decl) + !acc) + reactive; !acc let iter f t = match t with | Frozen decls -> Declarations.iter f decls - | Reactive reactive -> Reactive.iter f reactive + | Reactive reactive -> + Reactive.iter + (fun pos decl -> + f + (Stable.unsafe_to_nonlinear_value pos) + (Stable.unsafe_to_nonlinear_value decl)) + reactive diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index eafd54a40a..622715ad08 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -133,15 +133,19 @@ let process_files ~(collection : t) ~config:_ cmtFilePaths : let length (collection : t) = ReactiveFileCollection.length collection (** Get the underlying reactive collection for composition. - Returns (path, file_data option) suitable for ReactiveMerge. *) + Returns (path, file_data Maybe.t) suitable for ReactiveMerge. + Uses Maybe instead of option for zero allocation. *) let to_file_data_collection (collection : t) : - (string, DceFileProcessing.file_data option) Reactive.t = - Reactive.flatMap ~name:"file_data_collection" + (string, DceFileProcessing.file_data Maybe.t) Reactive.t = + Reactive.FlatMap.create ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) - ~f:(fun path result_opt -> + ~f:(fun path result_opt wave -> + let result_opt = Stable.to_linear_value result_opt in match result_opt with - | Some {dce_data = Some data; _} -> [(path, Some data)] - | _ -> [(path, None)]) + | Some {dce_data = Some data; _} -> + StableWave.push wave path + (Maybe.to_stable (Maybe.some (Stable.unsafe_of_value data))) + | _ -> StableWave.push wave path Maybe.none_stable) () (** Iterate over all file_data in the collection *) diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index 9f5a2ea26c..73644c9059 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -14,9 +14,17 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (Lexing.position, PosSet.t * PosSet.t) Reactive.t = (* Group declarations by file *) let decls_by_file : (string, (Lexing.position * Decl.t) list) Reactive.t = - Reactive.flatMap ~name:"decl_refs.decls_by_file" decls - ~f:(fun pos decl -> [(pos.Lexing.pos_fname, [(pos, decl)])]) - ~merge:( @ ) () + Reactive.FlatMap.create ~name:"decl_refs.decls_by_file" decls + ~f:(fun pos decl wave -> + let pos = Stable.to_linear_value pos in + let decl = Stable.to_linear_value decl in + StableWave.push wave + (Stable.unsafe_of_value pos.Lexing.pos_fname) + (Stable.unsafe_of_value [(pos, decl)])) + ~merge:(fun a b -> + Stable.unsafe_of_value + (Stable.to_linear_value a @ Stable.to_linear_value b)) + () in (* Check if posFrom is contained in decl's range *) @@ -28,56 +36,101 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* For each ref, find which decl(s) contain it and output (decl_pos, targets) *) let value_decl_refs : (Lexing.position, PosSet.t) Reactive.t = - Reactive.join ~name:"decl_refs.value_decl_refs" value_refs_from + Reactive.Join.create ~name:"decl_refs.value_decl_refs" value_refs_from decls_by_file - ~key_of:(fun posFrom _targets -> posFrom.Lexing.pos_fname) - ~f:(fun posFrom targets decls_opt -> - match decls_opt with - | None -> [] - | Some decls_in_file -> - decls_in_file - |> List.filter_map (fun (decl_pos, decl) -> - if pos_in_decl posFrom decl then Some (decl_pos, targets) - else None)) - ~merge:PosSet.union () + ~key_of:(fun posFrom _targets -> + Stable.unsafe_of_value (Stable.to_linear_value posFrom).Lexing.pos_fname) + ~f:(fun posFrom targets decls_mb wave -> + let posFrom = Stable.to_linear_value posFrom in + let targets = Stable.to_linear_value targets in + if Maybe.is_some decls_mb then + let decls_in_file = + Stable.to_linear_value (Maybe.unsafe_get decls_mb) + in + List.iter + (fun (decl_pos, decl) -> + if pos_in_decl posFrom decl then + StableWave.push wave + (Stable.unsafe_of_value decl_pos) + (Stable.unsafe_of_value targets)) + decls_in_file) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in let type_decl_refs : (Lexing.position, PosSet.t) Reactive.t = - Reactive.join ~name:"decl_refs.type_decl_refs" type_refs_from decls_by_file - ~key_of:(fun posFrom _targets -> posFrom.Lexing.pos_fname) - ~f:(fun posFrom targets decls_opt -> - match decls_opt with - | None -> [] - | Some decls_in_file -> - decls_in_file - |> List.filter_map (fun (decl_pos, decl) -> - if pos_in_decl posFrom decl then Some (decl_pos, targets) - else None)) - ~merge:PosSet.union () + Reactive.Join.create ~name:"decl_refs.type_decl_refs" type_refs_from + decls_by_file + ~key_of:(fun posFrom _targets -> + Stable.unsafe_of_value (Stable.to_linear_value posFrom).Lexing.pos_fname) + ~f:(fun posFrom targets decls_mb wave -> + let posFrom = Stable.to_linear_value posFrom in + let targets = Stable.to_linear_value targets in + if Maybe.is_some decls_mb then + let decls_in_file = + Stable.to_linear_value (Maybe.unsafe_get decls_mb) + in + List.iter + (fun (decl_pos, decl) -> + if pos_in_decl posFrom decl then + StableWave.push wave + (Stable.unsafe_of_value decl_pos) + (Stable.unsafe_of_value targets)) + decls_in_file) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Combine value and type refs into (value_targets, type_targets) pairs. Use join to combine, with decls as the base to ensure all decls are present. *) let with_value_refs : (Lexing.position, PosSet.t) Reactive.t = - Reactive.join ~name:"decl_refs.with_value_refs" decls value_decl_refs + Reactive.Join.create ~name:"decl_refs.with_value_refs" decls value_decl_refs ~key_of:(fun pos _decl -> pos) - ~f:(fun pos _decl refs_opt -> - [(pos, Option.value refs_opt ~default:PosSet.empty)]) + ~f:(fun pos _decl refs_mb wave -> + let pos = Stable.to_linear_value pos in + let refs = + if Maybe.is_some refs_mb then + Stable.to_linear_value (Maybe.unsafe_get refs_mb) + else PosSet.empty + in + StableWave.push wave + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value refs)) () in let with_type_refs : (Lexing.position, PosSet.t) Reactive.t = - Reactive.join ~name:"decl_refs.with_type_refs" decls type_decl_refs + Reactive.Join.create ~name:"decl_refs.with_type_refs" decls type_decl_refs ~key_of:(fun pos _decl -> pos) - ~f:(fun pos _decl refs_opt -> - [(pos, Option.value refs_opt ~default:PosSet.empty)]) + ~f:(fun pos _decl refs_mb wave -> + let pos = Stable.to_linear_value pos in + let refs = + if Maybe.is_some refs_mb then + Stable.to_linear_value (Maybe.unsafe_get refs_mb) + else PosSet.empty + in + StableWave.push wave + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value refs)) () in (* Combine into final (value_targets, type_targets) pairs *) - Reactive.join ~name:"decl_refs.combined" with_value_refs with_type_refs + Reactive.Join.create ~name:"decl_refs.combined" with_value_refs with_type_refs ~key_of:(fun pos _value_targets -> pos) - ~f:(fun pos value_targets type_targets_opt -> - let type_targets = Option.value type_targets_opt ~default:PosSet.empty in - [(pos, (value_targets, type_targets))]) + ~f:(fun pos value_targets type_targets_mb wave -> + let pos = Stable.to_linear_value pos in + let value_targets = Stable.to_linear_value value_targets in + let type_targets = + if Maybe.is_some type_targets_mb then + Stable.to_linear_value (Maybe.unsafe_get type_targets_mb) + else PosSet.empty + in + StableWave.push wave + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value (value_targets, type_targets))) () diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index 81e23bfbe6..5d8fcf8b6d 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -26,8 +26,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~(exception_refs : (DcePath.t, Location.t) Reactive.t) : t = (* Step 1: Index exception declarations by path *) let exception_decls = - Reactive.flatMap ~name:"exc_refs.exception_decls" decls - ~f:(fun _pos (decl : Decl.t) -> + Reactive.FlatMap.create ~name:"exc_refs.exception_decls" decls + ~f:(fun _pos decl wave -> + let decl : Decl.t = Stable.to_linear_value decl in match decl.Decl.declKind with | Exception -> let loc : Location.t = @@ -37,34 +38,49 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) loc_ghost = false; } in - [(decl.path, loc)] - | _ -> []) + StableWave.push wave + (Stable.unsafe_of_value decl.path) + (Stable.unsafe_of_value loc) + | _ -> ()) () (* Last-write-wins is fine since paths should be unique *) in (* Step 2: Join exception_refs with exception_decls *) let resolved_refs = - Reactive.join ~name:"exc_refs.resolved_refs" exception_refs exception_decls + Reactive.Join.create ~name:"exc_refs.resolved_refs" exception_refs + exception_decls ~key_of:(fun path _loc_from -> path) - ~f:(fun _path loc_from loc_to_opt -> - match loc_to_opt with - | Some loc_to -> + ~f:(fun _path loc_from loc_to_mb wave -> + let loc_from = Stable.to_linear_value loc_from in + if Maybe.is_some loc_to_mb then + let loc_to = Stable.to_linear_value (Maybe.unsafe_get loc_to_mb) in (* Add value reference: pos_to -> pos_from (refs_to direction) *) - [ - ( loc_to.Location.loc_start, - PosSet.singleton loc_from.Location.loc_start ); - ] - | None -> []) - ~merge:PosSet.union () + StableWave.push wave + (Stable.unsafe_of_value loc_to.Location.loc_start) + (Stable.unsafe_of_value + (PosSet.singleton loc_from.Location.loc_start))) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Step 3: Create refs_from direction by inverting *) let resolved_refs_from = - Reactive.flatMap ~name:"exc_refs.resolved_refs_from" resolved_refs - ~f:(fun posTo posFromSet -> - PosSet.elements posFromSet - |> List.map (fun posFrom -> (posFrom, PosSet.singleton posTo))) - ~merge:PosSet.union () + Reactive.FlatMap.create ~name:"exc_refs.resolved_refs_from" resolved_refs + ~f:(fun posTo posFromSet wave -> + let posTo = Stable.to_linear_value posTo in + let posFromSet = Stable.to_linear_value posFromSet in + PosSet.iter + (fun posFrom -> + StableWave.push wave + (Stable.unsafe_of_value posFrom) + (Stable.unsafe_of_value (PosSet.singleton posTo))) + posFromSet) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in {exception_decls; resolved_refs; resolved_refs_from} @@ -75,20 +91,22 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = Reactive.iter (fun posTo posFromSet -> + let posTo = Stable.to_linear_value posTo in PosSet.iter (fun posFrom -> References.add_value_ref refs ~posTo ~posFrom) - posFromSet) + (Stable.to_linear_value posFromSet)) t.resolved_refs (** Add file dependencies for resolved refs *) let add_to_file_deps_builder (t : t) ~(file_deps : FileDeps.builder) : unit = Reactive.iter (fun posTo posFromSet -> + let posTo = Stable.to_linear_value posTo in PosSet.iter (fun posFrom -> let from_file = posFrom.Lexing.pos_fname in let to_file = posTo.Lexing.pos_fname in if from_file <> to_file then FileDeps.add_dep file_deps ~from_file ~to_file) - posFromSet) + (Stable.to_linear_value posFromSet)) t.resolved_refs diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 4322bd0992..d61d6566e6 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -8,7 +8,7 @@ type t = { live: (Lexing.position, unit) Reactive.t; - edges: (Lexing.position, Lexing.position list) Reactive.t; + edges: (Lexing.position, Lexing.position StableList.t) Reactive.t; roots: (Lexing.position, unit) Reactive.t; } @@ -19,14 +19,22 @@ let create ~(merged : ReactiveMerge.t) : t = (* Combine value refs using union: per-file refs + exception refs *) let value_refs_from : (Lexing.position, PosSet.t) Reactive.t = - Reactive.union ~name:"liveness.value_refs_from" merged.value_refs_from - merged.exception_refs.resolved_refs_from ~merge:PosSet.union () + Reactive.Union.create ~name:"liveness.value_refs_from" + merged.value_refs_from merged.exception_refs.resolved_refs_from + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Combine type refs using union: per-file refs + type deps from ReactiveTypeDeps *) let type_refs_from : (Lexing.position, PosSet.t) Reactive.t = - Reactive.union ~name:"liveness.type_refs_from" merged.type_refs_from - merged.type_deps.all_type_refs_from ~merge:PosSet.union () + Reactive.Union.create ~name:"liveness.type_refs_from" merged.type_refs_from + merged.type_deps.all_type_refs_from + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Step 1: Build decl_refs_index - maps decl -> (value_targets, type_targets) *) @@ -35,11 +43,16 @@ let create ~(merged : ReactiveMerge.t) : t = in (* Step 2: Convert to edges format for fixpoint: decl -> successor list *) - let edges : (Lexing.position, Lexing.position list) Reactive.t = - Reactive.flatMap ~name:"liveness.edges" decl_refs_index - ~f:(fun pos (value_targets, type_targets) -> + let edges : (Lexing.position, Lexing.position StableList.t) Reactive.t = + Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index + ~f:(fun pos v wave -> + let pos = Stable.to_linear_value pos in + let value_targets, type_targets = Stable.to_linear_value v in let all_targets = PosSet.union value_targets type_targets in - [(pos, PosSet.elements all_targets)]) + StableWave.push wave + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value + (StableList.unsafe_of_list (PosSet.elements all_targets)))) () in @@ -55,66 +68,68 @@ let create ~(merged : ReactiveMerge.t) : t = We use join to explicitly track the dependency on decls. When a decl at position P arrives, any ref with posFrom=P will be reprocessed. *) let external_value_refs : (Lexing.position, unit) Reactive.t = - Reactive.join ~name:"liveness.external_value_refs" value_refs_from decls + Reactive.Join.create ~name:"liveness.external_value_refs" value_refs_from + decls ~key_of:(fun posFrom _targets -> posFrom) - ~f:(fun _posFrom targets decl_opt -> - match decl_opt with - | Some _ -> - (* posFrom IS a decl position, refs are internal *) - [] - | None -> + ~f:(fun _posFrom targets decl_mb wave -> + let targets = Stable.to_linear_value targets in + if not (Maybe.is_some decl_mb) then (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun posTo -> (posTo, ()))) - ~merge:(fun () () -> ()) + PosSet.elements targets + |> List.iter (fun posTo -> + StableWave.push wave (Stable.unsafe_of_value posTo) Stable.unit)) + ~merge:(fun _ _ -> Stable.unit) () in let external_type_refs : (Lexing.position, unit) Reactive.t = - Reactive.join ~name:"liveness.external_type_refs" type_refs_from decls + Reactive.Join.create ~name:"liveness.external_type_refs" type_refs_from + decls ~key_of:(fun posFrom _targets -> posFrom) - ~f:(fun _posFrom targets decl_opt -> - match decl_opt with - | Some _ -> - (* posFrom IS a decl position, refs are internal *) - [] - | None -> + ~f:(fun _posFrom targets decl_mb wave -> + let targets = Stable.to_linear_value targets in + if not (Maybe.is_some decl_mb) then (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun posTo -> (posTo, ()))) - ~merge:(fun () () -> ()) + PosSet.elements targets + |> List.iter (fun posTo -> + StableWave.push wave (Stable.unsafe_of_value posTo) Stable.unit)) + ~merge:(fun _ _ -> Stable.unit) () in let externally_referenced : (Lexing.position, unit) Reactive.t = - Reactive.union ~name:"liveness.externally_referenced" external_value_refs - external_type_refs - ~merge:(fun () () -> ()) + Reactive.Union.create ~name:"liveness.externally_referenced" + external_value_refs external_type_refs + ~merge:(fun _ _ -> Stable.unit) () in (* Compute annotated roots: decls with @live or @genType *) let annotated_roots : (Lexing.position, unit) Reactive.t = - Reactive.join ~name:"liveness.annotated_roots" decls annotations + Reactive.Join.create ~name:"liveness.annotated_roots" decls annotations ~key_of:(fun pos _decl -> pos) - ~f:(fun pos _decl ann_opt -> - match ann_opt with - | Some FileAnnotations.Live | Some FileAnnotations.GenType -> - [(pos, ())] - | _ -> []) - ~merge:(fun () () -> ()) + ~f:(fun pos _decl ann_mb wave -> + let pos = Stable.to_linear_value pos in + if Maybe.is_some ann_mb then + match Stable.to_linear_value (Maybe.unsafe_get ann_mb) with + | FileAnnotations.Live | FileAnnotations.GenType -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit + | _ -> ()) + ~merge:(fun _ _ -> Stable.unit) () in (* Combine all roots *) let all_roots : (Lexing.position, unit) Reactive.t = - Reactive.union ~name:"liveness.all_roots" annotated_roots + Reactive.Union.create ~name:"liveness.all_roots" annotated_roots externally_referenced - ~merge:(fun () () -> ()) + ~merge:(fun _ _ -> Stable.unit) () in (* Step 4: Compute fixpoint - all reachable positions from roots *) let live = - Reactive.fixpoint ~name:"liveness.live" ~init:all_roots ~edges () + Reactive.Fixpoint.create ~name:"liveness.live" ~init:all_roots ~edges () in {live; edges; roots = all_roots} diff --git a/analysis/reanalyze/src/ReactiveLiveness.mli b/analysis/reanalyze/src/ReactiveLiveness.mli index e0b5fcf53a..c603073248 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.mli +++ b/analysis/reanalyze/src/ReactiveLiveness.mli @@ -4,7 +4,7 @@ type t = { live: (Lexing.position, unit) Reactive.t; - edges: (Lexing.position, Lexing.position list) Reactive.t; + edges: (Lexing.position, Lexing.position StableList.t) Reactive.t; roots: (Lexing.position, unit) Reactive.t; } diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index f0a340f6c1..6474f907a2 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -21,109 +21,163 @@ type t = { (** {1 Creation} *) -let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : +let create (source : (string, DceFileProcessing.file_data Maybe.t) Reactive.t) : t = (* Declarations: (pos, Decl.t) with last-write-wins *) let decls = - Reactive.flatMap ~name:"decls" source - ~f:(fun _path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> - Declarations.builder_to_list file_data.DceFileProcessing.decls) + Reactive.FlatMap.create ~name:"decls" source + ~f:(fun _path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in + Declarations.builder_to_list file_data.DceFileProcessing.decls + |> List.iter (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v))) () in (* Annotations: (pos, annotated_as) with last-write-wins *) let annotations = - Reactive.flatMap ~name:"annotations" source - ~f:(fun _path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> + Reactive.FlatMap.create ~name:"annotations" source + ~f:(fun _path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in FileAnnotations.builder_to_list - file_data.DceFileProcessing.annotations) + file_data.DceFileProcessing.annotations + |> List.iter (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v))) () in (* Value refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let value_refs_from = - Reactive.flatMap ~name:"value_refs_from" source - ~f:(fun _path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> + Reactive.FlatMap.create ~name:"value_refs_from" source + ~f:(fun _path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in References.builder_value_refs_from_list - file_data.DceFileProcessing.refs) - ~merge:PosSet.union () + file_data.DceFileProcessing.refs + |> List.iter (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v))) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Type refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let type_refs_from = - Reactive.flatMap ~name:"type_refs_from" source - ~f:(fun _path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> + Reactive.FlatMap.create ~name:"type_refs_from" source + ~f:(fun _path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in References.builder_type_refs_from_list - file_data.DceFileProcessing.refs) - ~merge:PosSet.union () + file_data.DceFileProcessing.refs + |> List.iter (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v))) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Cross-file items: (path, CrossFileItems.t) with merge by concatenation *) let cross_file_items = - Reactive.flatMap ~name:"cross_file_items" source - ~f:(fun path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> + Reactive.FlatMap.create ~name:"cross_file_items" source + ~f:(fun path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in let items = CrossFileItems.builder_to_t file_data.DceFileProcessing.cross_file in - [(path, items)]) + StableWave.push wave path (Stable.unsafe_of_value items)) ~merge:(fun a b -> - CrossFileItems. - { - exception_refs = a.exception_refs @ b.exception_refs; - optional_arg_calls = a.optional_arg_calls @ b.optional_arg_calls; - function_refs = a.function_refs @ b.function_refs; - }) + let a = Stable.to_linear_value a in + let b = Stable.to_linear_value b in + Stable.unsafe_of_value + CrossFileItems. + { + exception_refs = a.exception_refs @ b.exception_refs; + optional_arg_calls = a.optional_arg_calls @ b.optional_arg_calls; + function_refs = a.function_refs @ b.function_refs; + }) () in (* File deps map: (from_file, FileSet of to_files) with FileSet.union merge *) let file_deps_map = - Reactive.flatMap ~name:"file_deps_map" source - ~f:(fun _path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> - FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps) - ~merge:FileSet.union () + Reactive.FlatMap.create ~name:"file_deps_map" source + ~f:(fun _path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in + FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps + |> List.iter (fun (k, v) -> + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v))) + ~merge:(fun a b -> + Stable.unsafe_of_value + (FileSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Files set: (source_path, ()) - just track which source files exist *) let files = - Reactive.flatMap ~name:"files" source - ~f:(fun _cmt_path file_data_opt -> - match file_data_opt with - | None -> [] - | Some file_data -> - (* Include all source files from file_deps (NOT the CMT path) *) + Reactive.FlatMap.create ~name:"files" source + ~f:(fun _cmt_path file_data_maybe wave -> + let file_data_maybe = Maybe.of_stable file_data_maybe in + if Maybe.is_none file_data_maybe then () + else + let file_data = + Stable.to_linear_value (Maybe.unsafe_get file_data_maybe) + in let file_set = FileDeps.builder_files file_data.DceFileProcessing.file_deps in - FileSet.fold (fun f acc -> (f, ()) :: acc) file_set []) + FileSet.iter + (fun f -> + StableWave.push wave (Stable.unsafe_of_value f) + (Stable.unsafe_of_value ())) + file_set) () in (* Extract exception_refs from cross_file_items for ReactiveExceptionRefs *) let exception_refs_collection = - Reactive.flatMap ~name:"exception_refs_collection" cross_file_items - ~f:(fun _path items -> + Reactive.FlatMap.create ~name:"exception_refs_collection" cross_file_items + ~f:(fun _path items wave -> + let items = Stable.to_linear_value items in items.CrossFileItems.exception_refs - |> List.map (fun (r : CrossFileItems.exception_ref) -> - (r.exception_path, r.loc_from))) + |> List.iter (fun (r : CrossFileItems.exception_ref) -> + StableWave.push wave + (Stable.unsafe_of_value r.exception_path) + (Stable.unsafe_of_value r.loc_from))) () in @@ -157,13 +211,23 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (** Convert reactive decls to Declarations.t for solver *) let freeze_decls (t : t) : Declarations.t = let result = PosHash.create 256 in - Reactive.iter (fun pos decl -> PosHash.replace result pos decl) t.decls; + Reactive.iter + (fun pos decl -> + PosHash.replace result + (Stable.unsafe_to_nonlinear_value pos) + (Stable.unsafe_to_nonlinear_value decl)) + t.decls; Declarations.create_from_hashtbl result (** Convert reactive annotations to FileAnnotations.t for solver *) let freeze_annotations (t : t) : FileAnnotations.t = let result = PosHash.create 256 in - Reactive.iter (fun pos ann -> PosHash.replace result pos ann) t.annotations; + Reactive.iter + (fun pos ann -> + PosHash.replace result + (Stable.unsafe_to_nonlinear_value pos) + (Stable.unsafe_to_nonlinear_value ann)) + t.annotations; FileAnnotations.create_from_hashtbl result (** Convert reactive refs to References.t for solver. @@ -185,26 +249,29 @@ let freeze_refs (t : t) : References.t = (* Merge per-file value refs_from *) Reactive.iter (fun posFrom posToSet -> + let posFrom = Stable.to_linear_value posFrom in PosSet.iter (fun posTo -> add_to_from value_refs_from posFrom posTo) - posToSet) + (Stable.to_linear_value posToSet)) t.value_refs_from; (* Merge per-file type refs_from *) Reactive.iter (fun posFrom posToSet -> + let posFrom = Stable.to_linear_value posFrom in PosSet.iter (fun posTo -> add_to_from type_refs_from posFrom posTo) - posToSet) + (Stable.to_linear_value posToSet)) t.type_refs_from; (* Add type-label dependency refs from all sources *) let add_type_refs_from reactive = Reactive.iter (fun posFrom posToSet -> + let posFrom = Stable.to_linear_value posFrom in PosSet.iter (fun posTo -> add_to_from type_refs_from posFrom posTo) - posToSet) + (Stable.to_linear_value posToSet)) reactive in add_type_refs_from t.type_deps.all_type_refs_from; @@ -212,9 +279,10 @@ let freeze_refs (t : t) : References.t = (* Add exception refs (to value refs_from) *) Reactive.iter (fun posFrom posToSet -> + let posFrom = Stable.to_linear_value posFrom in PosSet.iter (fun posTo -> add_to_from value_refs_from posFrom posTo) - posToSet) + (Stable.to_linear_value posToSet)) t.exception_refs.resolved_refs_from; References.create ~value_refs_from ~type_refs_from @@ -226,6 +294,7 @@ let collect_cross_file_items (t : t) : CrossFileItems.t = let function_refs = ref [] in Reactive.iter (fun _path items -> + let items = Stable.unsafe_to_nonlinear_value items in exception_refs := items.CrossFileItems.exception_refs @ !exception_refs; optional_arg_calls := items.CrossFileItems.optional_arg_calls @ !optional_arg_calls; @@ -242,17 +311,23 @@ let collect_cross_file_items (t : t) : CrossFileItems.t = let freeze_file_deps (t : t) : FileDeps.t = let files = let result = ref FileSet.empty in - Reactive.iter (fun path () -> result := FileSet.add path !result) t.files; + Reactive.iter + (fun path _unit -> + result := FileSet.add (Stable.unsafe_to_nonlinear_value path) !result) + t.files; !result in let deps = FileDeps.FileHash.create 256 in Reactive.iter (fun from_file to_files -> - FileDeps.FileHash.replace deps from_file to_files) + FileDeps.FileHash.replace deps + (Stable.unsafe_to_nonlinear_value from_file) + (Stable.unsafe_to_nonlinear_value to_files)) t.file_deps_map; (* Add file deps from exception refs - iterate value_refs_from *) Reactive.iter (fun posFrom posToSet -> + let posFrom = Stable.to_linear_value posFrom in PosSet.iter (fun posTo -> let from_file = posFrom.Lexing.pos_fname in @@ -265,6 +340,6 @@ let freeze_file_deps (t : t) : FileDeps.t = in FileDeps.FileHash.replace deps from_file (FileSet.add to_file existing)) - posToSet) + (Stable.to_linear_value posToSet)) t.exception_refs.resolved_refs_from; FileDeps.create ~files ~deps diff --git a/analysis/reanalyze/src/ReactiveMerge.mli b/analysis/reanalyze/src/ReactiveMerge.mli index 181c37a695..e0a3b563e9 100644 --- a/analysis/reanalyze/src/ReactiveMerge.mli +++ b/analysis/reanalyze/src/ReactiveMerge.mli @@ -42,7 +42,7 @@ type t = { (** {1 Creation} *) -val create : (string, DceFileProcessing.file_data option) Reactive.t -> t +val create : (string, DceFileProcessing.file_data Maybe.t) Reactive.t -> t (** Create reactive merge from a file data collection. All derived collections update automatically when source changes. *) diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index dbe21b2b43..54841c2cc1 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -55,23 +55,19 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~(config : DceConfig.t) : t = (* dead_decls = decls where NOT in live (reactive join) *) let dead_decls = - Reactive.join ~name:"solver.dead_decls" decls live + Reactive.Join.create ~name:"solver.dead_decls" decls live ~key_of:(fun pos _decl -> pos) - ~f:(fun pos decl live_opt -> - match live_opt with - | None -> [(pos, decl)] - | Some () -> []) + ~f:(fun pos decl live_mb wave -> + if not (Maybe.is_some live_mb) then StableWave.push wave pos decl) () in (* live_decls = decls where in live (reactive join) *) let live_decls = - Reactive.join ~name:"solver.live_decls" decls live + Reactive.Join.create ~name:"solver.live_decls" decls live ~key_of:(fun pos _decl -> pos) - ~f:(fun pos decl live_opt -> - match live_opt with - | Some () -> [(pos, decl)] - | None -> []) + ~f:(fun pos decl live_mb wave -> + if Maybe.is_some live_mb then StableWave.push wave pos decl) () in @@ -79,43 +75,53 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let dead_modules = if not config.DceConfig.run.transitive then (* Dead modules only reported in transitive mode *) - Reactive.flatMap ~name:"solver.dead_modules_empty" dead_decls - ~f:(fun _ _ -> []) + Reactive.FlatMap.create ~name:"solver.dead_modules_empty" dead_decls + ~f:(fun _k _v _wave -> ()) () else (* modules_with_dead: (moduleName, (loc, fileName)) for each module with dead decls *) let modules_with_dead = - Reactive.flatMap ~name:"solver.modules_with_dead" dead_decls - ~f:(fun _pos decl -> - [ - ( decl_module_name decl, - (decl.moduleLoc, decl.pos.Lexing.pos_fname) ); - ]) + Reactive.FlatMap.create ~name:"solver.modules_with_dead" dead_decls + ~f:(fun _pos decl wave -> + let decl = Stable.to_linear_value decl in + StableWave.push wave + (Stable.unsafe_of_value (decl_module_name decl)) + (Stable.unsafe_of_value + (decl.moduleLoc, decl.pos.Lexing.pos_fname))) ~merge:(fun v1 _v2 -> v1) (* keep first *) () in (* modules_with_live: (moduleName, ()) for each module with live decls *) let modules_with_live = - Reactive.flatMap ~name:"solver.modules_with_live" live_decls - ~f:(fun _pos decl -> [(decl_module_name decl, ())]) + Reactive.FlatMap.create ~name:"solver.modules_with_live" live_decls + ~f:(fun _pos decl wave -> + let decl = Stable.to_linear_value decl in + StableWave.push wave + (Stable.unsafe_of_value (decl_module_name decl)) + (Stable.unsafe_of_value ())) () in (* Anti-join: modules in dead but not in live *) - Reactive.join ~name:"solver.dead_modules" modules_with_dead + Reactive.Join.create ~name:"solver.dead_modules" modules_with_dead modules_with_live - ~key_of:(fun modName (_loc, _fileName) -> modName) - ~f:(fun modName (loc, fileName) live_opt -> - match live_opt with - | None -> [(modName, (loc, fileName))] (* dead: no live decls *) - | Some () -> []) (* live: has at least one live decl *) + ~key_of:(fun modName _v -> modName) + ~f:(fun modName v live_mb wave -> + if not (Maybe.is_some live_mb) then StableWave.push wave modName v + (* dead: no live decls *)) () in (* Reactive per-file grouping of dead declarations *) let dead_decls_by_file = - Reactive.flatMap ~name:"solver.dead_decls_by_file" dead_decls - ~f:(fun _pos decl -> [(decl.pos.Lexing.pos_fname, [decl])]) - ~merge:(fun decls1 decls2 -> decls1 @ decls2) + Reactive.FlatMap.create ~name:"solver.dead_decls_by_file" dead_decls + ~f:(fun _pos decl wave -> + let decl = Stable.to_linear_value decl in + StableWave.push wave + (Stable.unsafe_of_value decl.pos.Lexing.pos_fname) + (Stable.unsafe_of_value [decl])) + ~merge:(fun decls1 decls2 -> + Stable.unsafe_of_value + (Stable.to_linear_value decls1 @ Stable.to_linear_value decls2)) () in @@ -130,11 +136,13 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let modules_with_values : (Name.t, unit) Hashtbl.t = Hashtbl.create 8 in (* shouldReport checks annotations reactively *) let shouldReport (decl : Decl.t) = - match Reactive.get annotations decl.pos with - | Some FileAnnotations.Live -> false - | Some FileAnnotations.GenType -> false - | Some FileAnnotations.Dead -> false - | None -> true + let ann = Reactive.get annotations (Stable.unsafe_of_value decl.pos) in + if Maybe.is_some ann then + match Stable.to_linear_value (Maybe.unsafe_get ann) with + | FileAnnotations.Live -> false + | FileAnnotations.GenType -> false + | FileAnnotations.Dead -> false + else true in (* Don't emit module issues here - track modules for later *) let checkModuleDead ~fileName:_ moduleName = @@ -150,7 +158,11 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) | Some refs_from -> (* Must iterate ALL refs since cross-file refs also count as "below" *) DeadCommon.make_hasRefBelow ~transitive - ~iter_value_refs_from:(fun f -> Reactive.iter f refs_from) + ~iter_value_refs_from:(fun f -> + Reactive.iter + (fun k v -> + f (Stable.to_linear_value k) (Stable.to_linear_value v)) + refs_from) in (* Sort within file and generate issues *) let sorted = decls |> List.fast_sort Decl.compareForReporting in @@ -169,51 +181,73 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let issues_by_file = match (transitive, value_refs_from) with | true, _ | false, None -> - Reactive.flatMap ~name:"solver.issues_by_file" dead_decls_by_file - ~f:(fun file decls -> [(file, issues_for_file file decls)]) + Reactive.FlatMap.create ~name:"solver.issues_by_file" dead_decls_by_file + ~f:(fun file decls wave -> + let file = Stable.to_linear_value file in + let decls = Stable.to_linear_value decls in + StableWave.push wave + (Stable.unsafe_of_value file) + (Stable.unsafe_of_value (issues_for_file file decls))) () | false, Some refs_from -> (* Create a singleton "refs token" that changes whenever refs_from changes, and join every file against it so per-file issues recompute. *) let refs_token = - Reactive.flatMap ~name:"solver.refs_token" refs_from - ~f:(fun _posFrom _targets -> [((), ())]) - ~merge:(fun _ _ -> ()) + Reactive.FlatMap.create ~name:"solver.refs_token" refs_from + ~f:(fun _posFrom _targets wave -> + StableWave.push wave + (Stable.unsafe_of_value ()) + (Stable.unsafe_of_value ())) + ~merge:(fun _ _ -> Stable.unsafe_of_value ()) () in - Reactive.join ~name:"solver.issues_by_file" dead_decls_by_file refs_token - ~key_of:(fun _file _decls -> ()) - ~f:(fun file decls _token_opt -> [(file, issues_for_file file decls)]) + Reactive.Join.create ~name:"solver.issues_by_file" dead_decls_by_file + refs_token + ~key_of:(fun _file _decls -> Stable.unsafe_of_value ()) + ~f:(fun file decls _token_mb wave -> + let file = Stable.to_linear_value file in + let decls = Stable.to_linear_value decls in + StableWave.push wave + (Stable.unsafe_of_value file) + (Stable.unsafe_of_value (issues_for_file file decls))) () in (* Reactive incorrect @dead: live decls with @dead annotation *) let incorrect_dead_decls = - Reactive.join ~name:"solver.incorrect_dead_decls" live_decls annotations + Reactive.Join.create ~name:"solver.incorrect_dead_decls" live_decls + annotations ~key_of:(fun pos _decl -> pos) - ~f:(fun pos decl ann_opt -> - match ann_opt with - | Some FileAnnotations.Dead -> [(pos, decl)] - | _ -> []) + ~f:(fun pos decl ann_mb wave -> + if Maybe.is_some ann_mb then + match Stable.to_linear_value (Maybe.unsafe_get ann_mb) with + | FileAnnotations.Dead -> StableWave.push wave pos decl + | _ -> ()) () in (* Reactive modules_with_reported: modules that have at least one reported dead value *) let modules_with_reported = - Reactive.flatMap ~name:"solver.modules_with_reported" issues_by_file - ~f:(fun _file (_issues, modules_list) -> - List.map (fun m -> (m, ())) modules_list) + Reactive.FlatMap.create ~name:"solver.modules_with_reported" issues_by_file + ~f:(fun _file v wave -> + let _issues, modules_list = Stable.to_linear_value v in + List.iter + (fun m -> + StableWave.push wave (Stable.unsafe_of_value m) + (Stable.unsafe_of_value ())) + modules_list) () in (* Reactive dead module issues: dead_modules joined with modules_with_reported *) let dead_module_issues = - Reactive.join ~name:"solver.dead_module_issues" dead_modules + Reactive.Join.create ~name:"solver.dead_module_issues" dead_modules modules_with_reported - ~key_of:(fun moduleName (_loc, _fileName) -> moduleName) - ~f:(fun moduleName (loc, fileName) has_reported_opt -> - match has_reported_opt with - | Some () -> + ~key_of:(fun moduleName _v -> moduleName) + ~f:(fun moduleName v has_reported_mb wave -> + let moduleName = Stable.to_linear_value moduleName in + let loc, fileName = Stable.to_linear_value v in + if Maybe.is_some has_reported_mb then let loc = if loc.Location.loc_ghost then let pos = @@ -227,8 +261,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - [(moduleName, AnalysisResult.make_dead_module_issue ~loc ~moduleName)] - | None -> []) + StableWave.push wave + (Stable.unsafe_of_value moduleName) + (Stable.unsafe_of_value + (AnalysisResult.make_dead_module_issue ~loc ~moduleName))) () in @@ -254,8 +290,9 @@ let check_module_dead ~(dead_modules : (Name.t, Location.t * string) Reactive.t) moduleName : Issue.t option = if Hashtbl.mem reported_modules moduleName then None else - match Reactive.get dead_modules moduleName with - | Some (loc, fileName) -> + let dm = Reactive.get dead_modules (Stable.unsafe_of_value moduleName) in + if Maybe.is_some dm then ( + let loc, fileName = Stable.to_linear_value (Maybe.unsafe_get dm) in Hashtbl.replace reported_modules moduleName (); let loc = if loc.Location.loc_ghost then @@ -267,8 +304,8 @@ let check_module_dead ~(dead_modules : (Name.t, Location.t * string) Reactive.t) {Location.loc_start = pos; loc_end = pos; loc_ghost = false} else loc in - Some (AnalysisResult.make_dead_module_issue ~loc ~moduleName) - | None -> None + Some (AnalysisResult.make_dead_module_issue ~loc ~moduleName)) + else None (** Collect issues from reactive issues_by_file. Only iterates the pre-computed reactive issues collection. @@ -284,7 +321,8 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) (* Collect incorrect @dead issues from reactive collection *) let incorrect_dead_issues = ref [] in Reactive.iter - (fun _pos (decl : Decl.t) -> + (fun _pos decl -> + let decl : Decl.t = Stable.to_linear_value decl in let issue = DeadCommon.makeDeadIssue ~decl ~message:" is annotated @dead but is live" @@ -303,7 +341,8 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) let num_files = ref 0 in let dead_issues = ref [] in Reactive.iter - (fun _file (file_issues, _modules_list) -> + (fun _file v -> + let file_issues, _modules_list = Stable.unsafe_to_nonlinear_value v in incr num_files; dead_issues := file_issues @ !dead_issues) t.issues_by_file; @@ -312,7 +351,8 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) (* Collect module issues from reactive dead_module_issues *) let module_issues = ref [] in Reactive.iter - (fun _moduleName issue -> module_issues := issue :: !module_issues) + (fun _moduleName issue -> + module_issues := Stable.unsafe_to_nonlinear_value issue :: !module_issues) t.dead_module_issues; let t3 = Unix.gettimeofday () in @@ -329,14 +369,15 @@ let collect_issues ~(t : t) ~(config : DceConfig.t) (** Iterate over live declarations *) let iter_live_decls ~(t : t) (f : Decl.t -> unit) : unit = - Reactive.iter (fun _pos decl -> f decl) t.live_decls + Reactive.iter (fun _pos decl -> f (Stable.to_linear_value decl)) t.live_decls (** Check if a position is live using the reactive collection. Returns true if pos is not a declaration (matches non-reactive behavior). *) let is_pos_live ~(t : t) (pos : Lexing.position) : bool = - match Reactive.get t.decls pos with - | None -> true (* not a declaration, assume live *) - | Some _ -> Reactive.get t.live pos <> None + let pos_s = Stable.unsafe_of_value pos in + let d = Reactive.get t.decls pos_s in + if not (Maybe.is_some d) then true (* not a declaration, assume live *) + else Maybe.is_some (Reactive.get t.live pos_s) (** Stats *) let stats ~(t : t) : int * int = diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 5fd0694405..156efd9920 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -49,52 +49,63 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~(report_types_dead_only_in_interface : bool) : t = (* Step 1: Index decls by path *) let decl_by_path = - Reactive.flatMap ~name:"type_deps.decl_by_path" decls - ~f:(fun _pos decl -> + Reactive.FlatMap.create ~name:"type_deps.decl_by_path" decls + ~f:(fun _pos decl wave -> + let decl = Stable.to_linear_value decl in match decl_to_info decl with - | Some info -> [(info.path, [info])] - | None -> []) - ~merge:List.append () + | Some info -> + StableWave.push wave + (Stable.unsafe_of_value info.path) + (Stable.unsafe_of_value [info]) + | None -> ()) + ~merge:(fun a b -> + Stable.unsafe_of_value + (List.append (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Step 2: Same-path refs - connect all decls at the same path *) let same_path_refs = - Reactive.flatMap ~name:"type_deps.same_path_refs" decl_by_path - ~f:(fun _path decls -> + Reactive.FlatMap.create ~name:"type_deps.same_path_refs" decl_by_path + ~f:(fun _path decls wave -> + let decls = Stable.to_linear_value decls in match decls with - | [] | [_] -> [] + | [] | [_] -> () | first :: rest -> - (* Connect each decl to the first one (and vice-versa if needed). - Original: extendTypeDependencies loc loc0 adds posTo=loc, posFrom=loc0 - So: posTo=other, posFrom=first *) rest - |> List.concat_map (fun other -> - (* Always add: other -> first (posTo=other, posFrom=first) *) - let refs = [(other.pos, PosSet.singleton first.pos)] in - if report_types_dead_only_in_interface then refs - else - (* Also add: first -> other (posTo=first, posFrom=other) *) - (first.pos, PosSet.singleton other.pos) :: refs)) - ~merge:PosSet.union () + |> List.iter (fun other -> + StableWave.push wave + (Stable.unsafe_of_value other.pos) + (Stable.unsafe_of_value (PosSet.singleton first.pos)); + if not report_types_dead_only_in_interface then + StableWave.push wave + (Stable.unsafe_of_value first.pos) + (Stable.unsafe_of_value (PosSet.singleton other.pos)))) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Step 3: Cross-file refs - connect impl decls to intf decls *) (* First, extract impl decls that need to look up intf *) let impl_decls = - Reactive.flatMap ~name:"type_deps.impl_decls" decls - ~f:(fun _pos decl -> + Reactive.FlatMap.create ~name:"type_deps.impl_decls" decls + ~f:(fun _pos decl wave -> + let decl = Stable.to_linear_value decl in match decl_to_info decl with | Some info when not info.is_interface -> ( match info.path with - | [] -> [] + | [] -> () | typeLabelName :: pathToType -> - (* Try two intf paths *) let path_1 = pathToType |> DcePath.moduleToInterface in let path_2 = path_1 |> DcePath.typeToInterface in let intf_path1 = typeLabelName :: path_1 in let intf_path2 = typeLabelName :: path_2 in - [(info.pos, (info, intf_path1, intf_path2))]) - | _ -> []) + StableWave.push wave + (Stable.unsafe_of_value info.pos) + (Stable.unsafe_of_value (info, intf_path1, intf_path2))) + | _ -> ()) () in @@ -102,45 +113,80 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Original: extendTypeDependencies loc loc1 where loc=impl, loc1=intf adds posTo=impl, posFrom=intf *) let impl_to_intf_refs = - Reactive.join ~name:"type_deps.impl_to_intf_refs" impl_decls decl_by_path - ~key_of:(fun _pos (_, intf_path1, _) -> intf_path1) - ~f:(fun _pos (info, _intf_path1, _intf_path2) intf_decls_opt -> - match intf_decls_opt with - | Some (intf_info :: _) -> - (* Found at path1: posTo=impl, posFrom=intf *) - let refs = [(info.pos, PosSet.singleton intf_info.pos)] in - if report_types_dead_only_in_interface then refs - else - (* Also: posTo=intf, posFrom=impl *) - (intf_info.pos, PosSet.singleton info.pos) :: refs - | _ -> []) - ~merge:PosSet.union () + Reactive.Join.create ~name:"type_deps.impl_to_intf_refs" impl_decls + decl_by_path + ~key_of:(fun _pos v -> + let _, intf_path1, _ = Stable.to_linear_value v in + Stable.unsafe_of_value intf_path1) + ~f:(fun _pos v intf_decls_mb wave -> + let info, _intf_path1, _intf_path2 = Stable.to_linear_value v in + if Maybe.is_some intf_decls_mb then + match Stable.to_linear_value (Maybe.unsafe_get intf_decls_mb) with + | intf_info :: _ -> + (* Found at path1: posTo=impl, posFrom=intf *) + StableWave.push wave + (Stable.unsafe_of_value info.pos) + (Stable.unsafe_of_value (PosSet.singleton intf_info.pos)); + if not report_types_dead_only_in_interface then + (* Also: posTo=intf, posFrom=impl *) + StableWave.push wave + (Stable.unsafe_of_value intf_info.pos) + (Stable.unsafe_of_value (PosSet.singleton info.pos)) + | [] -> ()) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Second join for path2 fallback *) let impl_needing_path2 = - Reactive.join ~name:"type_deps.impl_needing_path2" impl_decls decl_by_path - ~key_of:(fun _pos (_, intf_path1, _) -> intf_path1) - ~f:(fun pos (info, _intf_path1, intf_path2) intf_decls_opt -> - match intf_decls_opt with - | Some (_ :: _) -> [] (* Found at path1, skip *) - | _ -> [(pos, (info, intf_path2))]) + Reactive.Join.create ~name:"type_deps.impl_needing_path2" impl_decls + decl_by_path + ~key_of:(fun _pos v -> + let _, intf_path1, _ = Stable.to_linear_value v in + Stable.unsafe_of_value intf_path1) + ~f:(fun pos v intf_decls_mb wave -> + let pos = Stable.to_linear_value pos in + let info, _intf_path1, intf_path2 = Stable.to_linear_value v in + let found = + Maybe.is_some intf_decls_mb + && + match Stable.to_linear_value (Maybe.unsafe_get intf_decls_mb) with + | _ :: _ -> true + | [] -> false + in + if not found then + StableWave.push wave + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value (info, intf_path2))) () in let impl_to_intf_refs_path2 = - Reactive.join ~name:"type_deps.impl_to_intf_refs_path2" impl_needing_path2 - decl_by_path - ~key_of:(fun _pos (_, intf_path2) -> intf_path2) - ~f:(fun _pos (info, _) intf_decls_opt -> - match intf_decls_opt with - | Some (intf_info :: _) -> - (* posTo=impl, posFrom=intf *) - let refs = [(info.pos, PosSet.singleton intf_info.pos)] in - if report_types_dead_only_in_interface then refs - else (intf_info.pos, PosSet.singleton info.pos) :: refs - | _ -> []) - ~merge:PosSet.union () + Reactive.Join.create ~name:"type_deps.impl_to_intf_refs_path2" + impl_needing_path2 decl_by_path + ~key_of:(fun _pos v -> + let _, intf_path2 = Stable.to_linear_value v in + Stable.unsafe_of_value intf_path2) + ~f:(fun _pos v intf_decls_mb wave -> + let info, _ = Stable.to_linear_value v in + if Maybe.is_some intf_decls_mb then + match Stable.to_linear_value (Maybe.unsafe_get intf_decls_mb) with + | intf_info :: _ -> + (* posTo=impl, posFrom=intf *) + StableWave.push wave + (Stable.unsafe_of_value info.pos) + (Stable.unsafe_of_value (PosSet.singleton intf_info.pos)); + if not report_types_dead_only_in_interface then + StableWave.push wave + (Stable.unsafe_of_value intf_info.pos) + (Stable.unsafe_of_value (PosSet.singleton info.pos)) + | [] -> ()) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Also handle intf -> impl direction. @@ -149,46 +195,61 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) The intf->impl code in original only runs when isInterface=true, and the lookup is for finding the impl. *) let intf_decls = - Reactive.flatMap ~name:"type_deps.intf_decls" decls - ~f:(fun _pos decl -> + Reactive.FlatMap.create ~name:"type_deps.intf_decls" decls + ~f:(fun _pos decl wave -> + let decl = Stable.to_linear_value decl in match decl_to_info decl with | Some info when info.is_interface -> ( match info.path with - | [] -> [] + | [] -> () | typeLabelName :: pathToType -> let impl_path = typeLabelName :: DcePath.moduleToImplementation pathToType in - [(info.pos, (info, impl_path))]) - | _ -> []) + StableWave.push wave + (Stable.unsafe_of_value info.pos) + (Stable.unsafe_of_value (info, impl_path))) + | _ -> ()) () in let intf_to_impl_refs = - Reactive.join ~name:"type_deps.intf_to_impl_refs" intf_decls decl_by_path - ~key_of:(fun _pos (_, impl_path) -> impl_path) - ~f:(fun _pos (intf_info, _) impl_decls_opt -> - match impl_decls_opt with - | Some (impl_info :: _) -> - (* Original: extendTypeDependencies loc1 loc where loc1=intf, loc=impl - But wait, looking at the original code more carefully: - - if isInterface then - match find_one path1 with - | None -> () - | Some loc1 -> - extendTypeDependencies ~config ~refs loc1 loc; - if not Config.reportTypesDeadOnlyInInterface then - extendTypeDependencies ~config ~refs loc loc1 - - Here loc is the current intf decl, loc1 is the found impl. - So extendTypeDependencies loc1 loc means posTo=loc1=impl, posFrom=loc=intf - *) - let refs = [(impl_info.pos, PosSet.singleton intf_info.pos)] in - if report_types_dead_only_in_interface then refs - else (intf_info.pos, PosSet.singleton impl_info.pos) :: refs - | _ -> []) - ~merge:PosSet.union () + Reactive.Join.create ~name:"type_deps.intf_to_impl_refs" intf_decls + decl_by_path + ~key_of:(fun _pos v -> + let _, impl_path = Stable.to_linear_value v in + Stable.unsafe_of_value impl_path) + ~f:(fun _pos v impl_decls_mb wave -> + let intf_info, _ = Stable.to_linear_value v in + if Maybe.is_some impl_decls_mb then + match Stable.to_linear_value (Maybe.unsafe_get impl_decls_mb) with + | impl_info :: _ -> + (* Original: extendTypeDependencies loc1 loc where loc1=intf, loc=impl + But wait, looking at the original code more carefully: + + if isInterface then + match find_one path1 with + | None -> () + | Some loc1 -> + extendTypeDependencies ~config ~refs loc1 loc; + if not Config.reportTypesDeadOnlyInInterface then + extendTypeDependencies ~config ~refs loc loc1 + + Here loc is the current intf decl, loc1 is the found impl. + So extendTypeDependencies loc1 loc means posTo=loc1=impl, posFrom=loc=intf + *) + StableWave.push wave + (Stable.unsafe_of_value impl_info.pos) + (Stable.unsafe_of_value (PosSet.singleton intf_info.pos)); + if not report_types_dead_only_in_interface then + StableWave.push wave + (Stable.unsafe_of_value intf_info.pos) + (Stable.unsafe_of_value (PosSet.singleton impl_info.pos)) + | [] -> ()) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Cross-file refs are the combination of: @@ -207,22 +268,45 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Combine all refs_to sources using union *) let combined_refs_to = let u1 = - Reactive.union ~name:"type_deps.u1" same_path_refs cross_file_refs - ~merge:PosSet.union () + Reactive.Union.create ~name:"type_deps.u1" same_path_refs + cross_file_refs + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) + (Stable.to_linear_value b))) + () in let u2 = - Reactive.union ~name:"type_deps.u2" u1 impl_to_intf_refs_path2 - ~merge:PosSet.union () + Reactive.Union.create ~name:"type_deps.u2" u1 impl_to_intf_refs_path2 + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) + (Stable.to_linear_value b))) + () in - Reactive.union ~name:"type_deps.combined_refs_to" u2 intf_to_impl_refs - ~merge:PosSet.union () + Reactive.Union.create ~name:"type_deps.combined_refs_to" u2 + intf_to_impl_refs + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in (* Invert the combined refs_to to refs_from *) - Reactive.flatMap ~name:"type_deps.all_type_refs_from" combined_refs_to - ~f:(fun posTo posFromSet -> - PosSet.elements posFromSet - |> List.map (fun posFrom -> (posFrom, PosSet.singleton posTo))) - ~merge:PosSet.union () + Reactive.FlatMap.create ~name:"type_deps.all_type_refs_from" + combined_refs_to + ~f:(fun posTo posFromSet wave -> + let posTo = Stable.to_linear_value posTo in + let posFromSet = Stable.to_linear_value posFromSet in + PosSet.iter + (fun posFrom -> + StableWave.push wave + (Stable.unsafe_of_value posFrom) + (Stable.unsafe_of_value (PosSet.singleton posTo))) + posFromSet) + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in { @@ -241,7 +325,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let add_to_refs_builder (t : t) ~(refs : References.builder) : unit = Reactive.iter (fun posTo posFromSet -> + let posTo = Stable.to_linear_value posTo in PosSet.iter (fun posFrom -> References.add_type_ref refs ~posTo ~posFrom) - posFromSet) + (Stable.to_linear_value posFromSet)) t.all_type_refs diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index 64db1247b0..8a8881419d 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -340,7 +340,14 @@ let runAnalysis ~dce_config ~cmtRoot ~reactive_collection ~reactive_merge instead of mutable resolvedDead field. *) let is_live pos = ReactiveSolver.is_pos_live ~t:solver pos in let find_decl pos = - Reactive.get merged.ReactiveMerge.decls pos + let mb = + Reactive.get merged.ReactiveMerge.decls + (Stable.unsafe_of_value pos) + in + if Maybe.is_some mb then + Some + (Stable.unsafe_to_nonlinear_value (Maybe.unsafe_get mb)) + else None in let optional_args_state = CrossFileItemsStore.compute_optional_args_state diff --git a/analysis/reanalyze/src/ReanalyzeServer.ml b/analysis/reanalyze/src/ReanalyzeServer.ml index 09ceb3f5ec..4db8480603 100644 --- a/analysis/reanalyze/src/ReanalyzeServer.ml +++ b/analysis/reanalyze/src/ReanalyzeServer.ml @@ -96,14 +96,6 @@ module Server = struct let s = Gc.quick_stat () in mb_of_words s.live_words - type reactive_pipeline = { - dce_config: DceConfig.t; - reactive_collection: ReactiveAnalysis.t; - reactive_merge: ReactiveMerge.t; - reactive_liveness: ReactiveLiveness.t; - reactive_solver: ReactiveSolver.t; - } - type server_state = { parse_argv: string array -> string option; run_analysis: @@ -119,9 +111,12 @@ module Server = struct unit; config: server_config; cmtRoot: string option; - mutable pipeline: reactive_pipeline; + dce_config: DceConfig.t; + reactive_collection: ReactiveAnalysis.t; + reactive_merge: ReactiveMerge.t; + reactive_liveness: ReactiveLiveness.t; + reactive_solver: ReactiveSolver.t; stats: server_stats; - mutable config_snapshot: RunConfig.snapshot; } type request_info = { @@ -266,32 +261,6 @@ Examples: unlink_if_exists stderr_path) run - let create_reactive_pipeline () : reactive_pipeline = - let dce_config = DceConfig.current () in - let reactive_collection = ReactiveAnalysis.create ~config:dce_config in - let file_data_collection = - ReactiveAnalysis.to_file_data_collection reactive_collection - in - let reactive_merge = ReactiveMerge.create file_data_collection in - let reactive_liveness = ReactiveLiveness.create ~merged:reactive_merge in - let value_refs_from = - if dce_config.DceConfig.run.transitive then None - else Some reactive_merge.ReactiveMerge.value_refs_from - in - let reactive_solver = - ReactiveSolver.create ~decls:reactive_merge.ReactiveMerge.decls - ~live:reactive_liveness.ReactiveLiveness.live - ~annotations:reactive_merge.ReactiveMerge.annotations ~value_refs_from - ~config:dce_config - in - { - dce_config; - reactive_collection; - reactive_merge; - reactive_liveness; - reactive_solver; - } - let init_state ~(parse_argv : string array -> string option) ~(run_analysis : dce_config:DceConfig.t -> @@ -322,16 +291,39 @@ Examples: server with editor-like args only." !Cli.churn else - let pipeline = create_reactive_pipeline () in + let dce_config = DceConfig.current () in + let reactive_collection = + ReactiveAnalysis.create ~config:dce_config + in + let file_data_collection = + ReactiveAnalysis.to_file_data_collection reactive_collection + in + let reactive_merge = ReactiveMerge.create file_data_collection in + let reactive_liveness = + ReactiveLiveness.create ~merged:reactive_merge + in + let value_refs_from = + if dce_config.DceConfig.run.transitive then None + else Some reactive_merge.ReactiveMerge.value_refs_from + in + let reactive_solver = + ReactiveSolver.create ~decls:reactive_merge.ReactiveMerge.decls + ~live:reactive_liveness.ReactiveLiveness.live + ~annotations:reactive_merge.ReactiveMerge.annotations + ~value_refs_from ~config:dce_config + in Ok { parse_argv; run_analysis; config; cmtRoot; - pipeline; + dce_config; + reactive_collection; + reactive_merge; + reactive_liveness; + reactive_solver; stats = {request_count = 0}; - config_snapshot = RunConfig.snapshot (); }) let run_one_request (state : server_state) (_req : request) : @@ -355,17 +347,6 @@ Examples: (* Always run from the server's project root; client cwd is not stable in VS Code. *) state.config.cwd (fun () -> capture_stdout_stderr (fun () -> - (* Re-read config from rescript.json to detect changes. - If changed, recreate the entire reactive pipeline from scratch. *) - RunConfig.reset (); - Paths.Config.processConfig (); - let new_snapshot = RunConfig.snapshot () in - if - not - (RunConfig.equal_snapshot state.config_snapshot new_snapshot) - then ( - state.pipeline <- create_reactive_pipeline (); - state.config_snapshot <- new_snapshot); Log_.Color.setup (); Timing.enabled := !Cli.timing; Reactive.set_debug !Cli.timing; @@ -376,18 +357,18 @@ Examples: (* Match direct CLI output (a leading newline before the JSON array). *) Printf.printf "\n"; EmitJson.start (); - let p = state.pipeline in - state.run_analysis ~dce_config:p.dce_config ~cmtRoot:state.cmtRoot - ~reactive_collection:(Some p.reactive_collection) - ~reactive_merge:(Some p.reactive_merge) - ~reactive_liveness:(Some p.reactive_liveness) - ~reactive_solver:(Some p.reactive_solver) ~skip_file:None + state.run_analysis ~dce_config:state.dce_config + ~cmtRoot:state.cmtRoot + ~reactive_collection:(Some state.reactive_collection) + ~reactive_merge:(Some state.reactive_merge) + ~reactive_liveness:(Some state.reactive_liveness) + ~reactive_solver:(Some state.reactive_solver) ~skip_file:None ~file_stats (); issue_count := Log_.Stats.get_issue_count (); - let d, l = ReactiveSolver.stats ~t:p.reactive_solver in + let d, l = ReactiveSolver.stats ~t:state.reactive_solver in dead_count := d; live_count := l; - Log_.Stats.report ~config:p.dce_config; + Log_.Stats.report ~config:state.dce_config; Log_.Stats.clear (); EmitJson.finish ()) |> response_of_result) diff --git a/analysis/reanalyze/src/RunConfig.ml b/analysis/reanalyze/src/RunConfig.ml index b6b1d28008..3c33f79909 100644 --- a/analysis/reanalyze/src/RunConfig.ml +++ b/analysis/reanalyze/src/RunConfig.ml @@ -21,14 +21,6 @@ let runConfig = unsuppress = []; } -let reset () = - runConfig.dce <- false; - runConfig.exception_ <- false; - runConfig.suppress <- []; - runConfig.termination <- false; - runConfig.transitive <- false; - runConfig.unsuppress <- [] - let all () = runConfig.dce <- true; runConfig.exception_ <- true; @@ -39,24 +31,3 @@ let exception_ () = runConfig.exception_ <- true let termination () = runConfig.termination <- true let transitive b = runConfig.transitive <- b - -type snapshot = { - dce: bool; - exception_: bool; - suppress: string list; - termination: bool; - transitive: bool; - unsuppress: string list; -} - -let snapshot () = - { - dce = runConfig.dce; - exception_ = runConfig.exception_; - suppress = runConfig.suppress; - termination = runConfig.termination; - transitive = runConfig.transitive; - unsuppress = runConfig.unsuppress; - } - -let equal_snapshot (a : snapshot) (b : snapshot) = a = b diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/test-reactive-server.sh b/tests/analysis_tests/tests-reanalyze/deadcode/test-reactive-server.sh index d9e420bd2b..015d878cb2 100755 --- a/tests/analysis_tests/tests-reanalyze/deadcode/test-reactive-server.sh +++ b/tests/analysis_tests/tests-reanalyze/deadcode/test-reactive-server.sh @@ -58,9 +58,7 @@ time_end() { } BACKUP_FILE="/tmp/reactive-test-backup.$$" -CONFIG_BACKUP_FILE="/tmp/reactive-test-config-backup.$$" DEFAULT_SOCKET_FILE="" -CONFIG_FILE="" # Cleanup function cleanup() { @@ -69,11 +67,6 @@ cleanup() { cp "$BACKUP_FILE" "$TEST_FILE" rm -f "$BACKUP_FILE" fi - # Restore config file if backup exists - if [[ -n "$CONFIG_FILE" && -f "$CONFIG_BACKUP_FILE" ]]; then - cp "$CONFIG_BACKUP_FILE" "$CONFIG_FILE" - rm -f "$CONFIG_BACKUP_FILE" - fi # Stop server if running if [[ -n "$SERVER_PID" ]] && kill -0 "$SERVER_PID" 2>/dev/null; then kill "$SERVER_PID" 2>/dev/null || true @@ -197,12 +190,6 @@ configure_project() { log_error "Could not find test file for project: $project_name" exit 1 fi - - CONFIG_FILE="$PROJECT_DIR/rescript.json" - if [[ ! -f "$CONFIG_FILE" ]]; then - log_error "Could not find config file: $CONFIG_FILE" - exit 1 - fi } configure_project @@ -227,7 +214,6 @@ time_end "initial_build" # Backup the test file cp "$TEST_FILE" "$BACKUP_FILE" -cp "$CONFIG_FILE" "$CONFIG_BACKUP_FILE" # Start the server start_server() { @@ -277,6 +263,13 @@ send_request() { # shellcheck disable=SC2086 "$TOOLS_BIN" reanalyze $REANALYZE_ARGS > "$output_file" 2>/dev/null time_end "$label" + # Check that the server is still alive + if ! kill -0 "$SERVER_PID" 2>/dev/null; then + log_error "Server crashed during $label request!" + log_error "Server log:" + cat /tmp/reanalyze-server-$$.log + return 1 + fi } # Run standalone (non-reactive) analysis for comparison @@ -346,24 +339,6 @@ PY time_end "json_compare" } -set_config_suppress_all() { - python3 - <