From 606bc075a6dba9862d6e9c3024623d6658dd9348 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Mar 2026 11:25:45 +0100 Subject: [PATCH 01/54] reactive: zero-alloc current mechanism (squashed) - Zero-alloc fixpoint, flatMap, join, union, source, scheduler - ReactiveHash.Map/Set with ReactiveMaybe for zero-alloc lookups - ReactivePoolMapSet for zero-alloc map-of-sets with set recycling - ReactivePoolMapMap for zero-alloc map-of-maps with inner-map recycling - ReactiveAllocTrace with two-level tracing (alloc-only vs alloc+ops) - Wave-based emit API with ReactiveMaybe - Comprehensive allocation tests Signed-Off-By: Cristiano Calcagno --- CHANGELOG.md | 4 - analysis/reactive/README.md | 5 +- .../hyperindex_replay_build_times.sh | 245 +++- .../reactive/src/CONVERTING_COMBINATORS.md | 356 ++++++ analysis/reactive/src/POOL_MAP_MAP.md | 149 +++ analysis/reactive/src/POOL_MAP_SET.md | 121 ++ analysis/reactive/src/Reactive.ml | 1024 ++++++----------- analysis/reactive/src/Reactive.mli | 41 +- analysis/reactive/src/ReactiveAllocTrace.ml | 80 ++ .../reactive/src/ReactiveFileCollection.ml | 73 +- analysis/reactive/src/ReactiveFixpoint.ml | 856 ++++++++------ analysis/reactive/src/ReactiveFixpoint.mli | 75 +- analysis/reactive/src/ReactiveFlatMap.ml | 152 +++ analysis/reactive/src/ReactiveFlatMap.mli | 35 + analysis/reactive/src/ReactiveHash.ml | 434 +++++++ analysis/reactive/src/ReactiveHash.mli | 63 + analysis/reactive/src/ReactiveJoin.ml | 214 ++++ analysis/reactive/src/ReactiveJoin.mli | 43 + analysis/reactive/src/ReactiveMaybe.ml | 17 + analysis/reactive/src/ReactiveMaybe.mli | 17 + analysis/reactive/src/ReactivePoolMapMap.ml | 102 ++ analysis/reactive/src/ReactivePoolMapMap.mli | 42 + analysis/reactive/src/ReactivePoolMapSet.ml | 107 ++ analysis/reactive/src/ReactivePoolMapSet.mli | 42 + analysis/reactive/src/ReactiveQueue.ml | 36 + analysis/reactive/src/ReactiveQueue.mli | 13 + analysis/reactive/src/ReactiveUnion.ml | 141 +++ analysis/reactive/src/ReactiveUnion.mli | 41 + analysis/reactive/src/ReactiveWave.ml | 31 + analysis/reactive/src/ReactiveWave.mli | 13 + analysis/reactive/src/dune | 2 +- analysis/reactive/test/AllocMeasure.ml | 19 + analysis/reactive/test/AllocTest.ml | 642 +++++++++++ analysis/reactive/test/BatchTest.ml | 44 +- analysis/reactive/test/FixpointBasicTest.ml | 107 +- .../reactive/test/FixpointIncrementalTest.ml | 479 ++++---- analysis/reactive/test/FlatMapTest.ml | 80 +- analysis/reactive/test/GlitchFreeTest.ml | 131 +-- analysis/reactive/test/IntegrationTest.ml | 28 +- analysis/reactive/test/JoinTest.ml | 73 +- analysis/reactive/test/ReactiveTest.ml | 1 + analysis/reactive/test/TestHelpers.ml | 76 +- analysis/reactive/test/UnionTest.ml | 96 +- analysis/reactive/test/dune | 4 +- analysis/reanalyze/src/AnnotationStore.ml | 25 +- analysis/reanalyze/src/DeadCommon.ml | 4 +- analysis/reanalyze/src/DeclarationStore.ml | 2 +- analysis/reanalyze/src/ReactiveAnalysis.ml | 6 +- analysis/reanalyze/src/ReactiveDeclRefs.ml | 58 +- .../reanalyze/src/ReactiveExceptionRefs.ml | 26 +- analysis/reanalyze/src/ReactiveLiveness.ml | 34 +- analysis/reanalyze/src/ReactiveMerge.ml | 53 +- analysis/reanalyze/src/ReactiveSolver.ml | 90 +- analysis/reanalyze/src/ReactiveTypeDeps.ml | 135 +-- analysis/reanalyze/src/Reanalyze.ml | 3 +- analysis/reanalyze/src/ReanalyzeServer.ml | 97 +- analysis/reanalyze/src/RunConfig.ml | 29 - .../deadcode/test-reactive-server.sh | 77 +- 58 files changed, 4930 insertions(+), 2063 deletions(-) create mode 100644 analysis/reactive/src/CONVERTING_COMBINATORS.md create mode 100644 analysis/reactive/src/POOL_MAP_MAP.md create mode 100644 analysis/reactive/src/POOL_MAP_SET.md create mode 100644 analysis/reactive/src/ReactiveAllocTrace.ml create mode 100644 analysis/reactive/src/ReactiveFlatMap.ml create mode 100644 analysis/reactive/src/ReactiveFlatMap.mli create mode 100644 analysis/reactive/src/ReactiveHash.ml create mode 100644 analysis/reactive/src/ReactiveHash.mli create mode 100644 analysis/reactive/src/ReactiveJoin.ml create mode 100644 analysis/reactive/src/ReactiveJoin.mli create mode 100644 analysis/reactive/src/ReactiveMaybe.ml create mode 100644 analysis/reactive/src/ReactiveMaybe.mli create mode 100644 analysis/reactive/src/ReactivePoolMapMap.ml create mode 100644 analysis/reactive/src/ReactivePoolMapMap.mli create mode 100644 analysis/reactive/src/ReactivePoolMapSet.ml create mode 100644 analysis/reactive/src/ReactivePoolMapSet.mli create mode 100644 analysis/reactive/src/ReactiveQueue.ml create mode 100644 analysis/reactive/src/ReactiveQueue.mli create mode 100644 analysis/reactive/src/ReactiveUnion.ml create mode 100644 analysis/reactive/src/ReactiveUnion.mli create mode 100644 analysis/reactive/src/ReactiveWave.ml create mode 100644 analysis/reactive/src/ReactiveWave.mli create mode 100644 analysis/reactive/test/AllocMeasure.ml create mode 100644 analysis/reactive/test/AllocTest.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index dda0db3f45e..88c60f35bd3 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 9f55e57eff1..813cae749f4 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/experiments/hyperindex_replay_build_times.sh b/analysis/reactive/experiments/hyperindex_replay_build_times.sh index 4b6485749c0..ea8f73364a3 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/CONVERTING_COMBINATORS.md b/analysis/reactive/src/CONVERTING_COMBINATORS.md new file mode 100644 index 00000000000..3bb65f6c769 --- /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 `ReactiveMaybe` instead of `option` for lookups + +`ReactiveHash.Map.find_maybe` returns a `ReactiveMaybe.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 ReactiveMaybe.is_some r then + use (ReactiveMaybe.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 `ReactiveMaybe.t` does not +save allocations (confirmed by measurement). Focus optimization +effort on closures and non-unit option types instead. + +### Use `ReactiveQueue` for BFS/worklist patterns + +Pre-allocated array-based FIFOs (`ReactiveQueue`) 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 `ReactiveQueue` (pre-allocated array-based 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/POOL_MAP_MAP.md b/analysis/reactive/src/POOL_MAP_MAP.md new file mode 100644 index 00000000000..198c0f2ed38 --- /dev/null +++ b/analysis/reactive/src/POOL_MAP_MAP.md @@ -0,0 +1,149 @@ +# ReactivePoolMapMap: Design Draft (from production lessons) + +## Why this exists + +`ReactivePoolMapSet` removed important churn footguns for `Map>`. +We still have `Map>` shapes in reactive internals with similar risks: + +- per-key inner container allocation/discovery, +- empty inner maps lingering unless callers remember to remove them, +- fragmentation pressure split across many independently sized inners. + +Goal: centralize lifecycle/recycling for inner maps, so callers cannot accidentally leak empty inners or bypass reuse. + +## Inventory of current map-of-map usage + +### 1) `ReactiveFlatMap.contributions` + +File: `ReactiveFlatMap.ml` + +Shape: + +- outer key: `k2` (derived key) +- inner key: `k1` (source key) +- value: `v2` (contribution payload) + +Ops pattern: + +- add/update one inner entry (`k2`,`k1`) frequently, +- remove one inner entry on source churn, +- recompute aggregate by iterating inner map for one `k2`, +- if inner becomes empty, target is removed. + +Current footgun: empty inner contribution maps are not always removed/recycled by construction. + +### 2) `ReactiveJoin.contributions` + +File: `ReactiveJoin.ml` + +Same shape and lifecycle as flatMap: + +- outer key: `k3` +- inner key: `k1` +- value: `v3` + +### 3) `ReactiveFixpoint.pred_map` + +File: `ReactiveFixpoint.ml` + +Type is map-of-map (`k -> (pred -> unit)`), but semantically this is map-of-set. +This likely belongs on `ReactivePoolMapSet` (or equivalent set API helpers), not a generic map-of-map API. + +## Design constraints carried from PoolMapSet + +1. Public API must encode correct teardown semantics. + +- Avoid exposing mutable inner map handles as a normal path. +- Prefer operation names that force recycling decisions. + +2. Keep diagnostics first-class. + +- Track miss and pool-resize independently. +- Request-attributed trace events for realistic replay analysis. + +3. Validate with realistic replay, then encode budgets in tests. + +- As with PoolMapSet, startup and steady-state must be analyzed separately. +- Tests should assert post-warmup miss deltas for typical churn patterns. + +## Proposed minimal API (v0 draft) + +```ocaml +type ('ko, 'ki, 'v) t + +val create : capacity:int -> ('ko, 'ki, 'v) t + +val replace : ('ko, 'ki, 'v) t -> 'ko -> 'ki -> 'v -> unit +(** Ensure inner map for outer key and set one entry. *) + +val remove_from_inner_and_recycle_if_empty : + ('ko, 'ki, 'v) t -> 'ko -> 'ki -> unit +(** Remove one inner entry; recycle and remove outer key if inner becomes empty. *) + +val drain_outer : + ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit +(** Iterate all entries for one outer key, then recycle that inner map. *) + +val iter_inner_with : + ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit +(** Read-only iteration for one outer key without exposing mutable inner map. *) + +val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko -> int +val outer_cardinal : ('ko, 'ki, 'v) t -> int + +val find_inner_maybe : + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t ReactiveMaybe.t +(** Optional: keep internal/private if we want stricter discipline. *) + +val tighten : ('ko, 'ki, 'v) t -> unit + +val debug_miss_count : ('ko, 'ki, 'v) t -> int +``` + +## Why this API shape + +- `replace` + `remove_from_inner_and_recycle_if_empty` is the map-of-map analog of the safe PoolMapSet pair. +- `drain_outer` provides the whole-key teardown fast path. +- `iter_inner_with` avoids the main footgun: callers mutating inner maps directly and bypassing recycle. + +## Instrumentation (draft) + +Emitted event names in `ReactiveAllocTrace`: + +- `pool_map_resize` +- `pool_map_miss_create` +- `pool_map_drain_outer` +- `pool_map_remove_recycle_if_empty` + +The replay script should summarize miss/create vs pool-resize separately (same as PoolMapSet). + +## Migration status + +- Implemented: `ReactivePoolMapMap` module (API-aligned with this draft). +- Implemented: `ReactiveFlatMap.contributions` migrated to `ReactivePoolMapMap`. +- Implemented: `ReactiveJoin.contributions` migrated to `ReactivePoolMapMap`. +- Implemented decision: `ReactiveFixpoint.pred_map` migrated to + `ReactivePoolMapSet` (semantic map-of-set), not `ReactivePoolMapMap`. + +## Initial migration targets + +1. `ReactiveFlatMap.contributions` + +- Replace ad-hoc `get_contributions + Map.remove` with PoolMapMap operations. +- Ensure per-source removal path always uses `remove_from_inner_and_recycle_if_empty`. + +2. `ReactiveJoin.contributions` + +- Same migration pattern as flatMap. + +3. `ReactiveFixpoint.pred_map` + +- Done: migrated to `ReactivePoolMapSet` (map-of-set semantics). + +## Test plan (mirrors PoolMapSet) + +- Add allocation tests that mimic actual flatMap/join churn (not synthetic random patterns). +- Assert in measured phase: + - pool-map miss delta is zero for stable-key churn, + - functional result matches baseline, + - optional: bounded pool-map resize events after warmup. diff --git a/analysis/reactive/src/POOL_MAP_SET.md b/analysis/reactive/src/POOL_MAP_SET.md new file mode 100644 index 00000000000..c43ecf5f392 --- /dev/null +++ b/analysis/reactive/src/POOL_MAP_SET.md @@ -0,0 +1,121 @@ +# ReactivePoolMapSet: Production Notes and API Guidance + +## Purpose + +`ReactivePoolMapSet` implements a pooled `Map>` for churn-heavy paths +(`flatMap` provenance and `join` provenance/reverse index). + +Goal: reduce allocation from nested-structure churn by recycling inner sets. + +## Current Public API (single API) + +- `create ~capacity` +- `add` +- `drain_key` +- `remove_from_set_and_recycle_if_empty` +- `find_maybe` +- `iter_with` +- `clear` +- `tighten` +- `cardinal` +- `debug_miss_count` (diagnostics/tests) + +`ensure` is intentionally internal. + +## Semantics that matter + +- `add` on an absent key: + - reuses a set from pool if available, + - otherwise allocates a fresh set (`pool_set_miss_create`). +- `drain_key`: + - iterates values for one key, + - removes key from outer map, + - clears and recycles the set. +- `remove_from_set_and_recycle_if_empty`: + - removes one value, + - recycles the set only if it becomes empty. +- Pool grows on demand (`pool_set_resize`) when recycled-set stack is full. + +## What we measured on real workload + +Experiment: full hyperindex replay (`benchmark/rescript-baseline..benchmark/rescript-followup`, 56 commits), reactive-only, request-attributed allocation log. + +Observed from `alloc-events.log`: + +- Startup phase (before first request): + - 331 alloc events (`map_create`, `set_create` only). +- Request phase totals: + - `pool_set_miss_create`: 31,963 + - `pool_set_resize`: 63 + - `pool_set_drain_key`: 542,071 + - `pool_set_remove_recycle_if_empty`: 544,768 +- Misses are heavily front-loaded: + - request 1: 31,825 misses + - requests 2..56 combined: 138 misses (~0.43% of total misses) +- Resizes are non-zero after warmup: + - 63 total (`join.right_key_to_left_keys`: 29, `join.provenance`: 18, `flatmap.provenance`: 16) + +Takeaway: recycling dominates steady state; late allocations exist but are small for misses and non-zero for pool-stack growth. + +## Best practices (from production replay) + +1. Use only churn-safe teardown operations. + +- For whole-key teardown: `drain_key`. +- For inverse-index unlink: `remove_from_set_and_recycle_if_empty`. +- Avoid API shapes that remove entries without recycling. + +2. Warm up before judging allocation behavior. + +- First request/phase discovers sizes and pays most miss costs. +- Evaluate steady-state from later requests, not request 1. + +3. Track pool misses and pool resizes separately. + +- `pool_set_miss_create` answers "fresh inner-set allocation". +- `pool_set_resize` answers "pool metadata growth pressure". +- Both are needed; misses alone are not the whole picture. + +4. Keep attribution in the same log stream. + +- Use request markers (`ALLOC_REQ_BEGIN/SUMMARY/END`) in alloc log. +- Include startup phase markers. +- This is required to connect events to concrete commits/requests. + +5. Set initial capacity from expected concurrent recycled keys. + +- Too small: more `pool_set_resize` and potential pressure. +- Too large: higher resident memory. +- Current implementation grows on demand; initial capacity still affects early behavior. + +6. Use `tighten` deliberately, not continuously. + +- `tighten` is allocating by design. +- Reserve it for explicit maintenance points after major churn phases. + +## Test guidance (important) + +For this structure, "no allocation" should be specified precisely: + +- If requirement is "no fresh set allocation after warmup under churn", + assert `debug_miss_count` delta is `0` in measured phase. +- Do not equate this with `words/iter = 0` in generic churn loops: + other structures (outer map/set internals, diagnostics, etc.) may allocate. + +Current churn tests in `AllocTest.ml` use this pattern: + +- warmup first, +- measure churn loop, +- assert `pool_miss_delta = 0`. + +## Reusable lessons for Map-of-Map work + +Use this exact process for `Map>`: + +1. Define churn-safe teardown APIs first (remove+recycle semantics explicit). +2. Add event-level instrumentation for misses/resizes with request attribution. +3. Run realistic replay, not only synthetic microbenchmarks. +4. Separate startup from steady-state in analysis. +5. Convert findings into budgeted assertions in tests (post-warmup deltas). + +This avoids overfitting to synthetic "zero words/iter" and keeps API design aligned with production behavior. diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 9db201901dc..b99a4c3bf46 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -1,47 +1,31 @@ (** 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 + This eliminates glitches from multi-level dependencies. *) -let set k v = (k, Some v) -let remove k = (k, None) +(** {1 Waves} *) -let delta_to_entries = function - | Set (k, v) -> [(k, Some v)] - | Remove k -> [(k, None)] - | Batch entries -> entries +type ('k, 'v) wave = ('k, 'v ReactiveMaybe.t) ReactiveWave.t -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 [] +let wave_max_entries_default = + match Sys.getenv_opt "RESCRIPT_REACTIVE_WAVE_MAX_ENTRIES" with + | Some s -> ( + match int_of_string_opt s with + | Some n when n > 0 -> n + | _ -> 65_536) + | None -> 65_536 -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 () = ReactiveWave.create ~max_entries:wave_max_entries_default (** {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 +54,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,6 +68,7 @@ module Registry = struct mutable upstream: string list; mutable downstream: string list; mutable dirty: bool; + mutable outbound_inflight: int; process: unit -> unit; (* Process accumulated deltas *) stats: stats; } @@ -106,7 +79,14 @@ 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 [] + + (* 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. *) + let sorted_nodes : node_info array ref = ref [||] + let sorted_valid = ref true let register ~name ~level ~process ~stats = let info = @@ -116,11 +96,13 @@ module Registry = struct upstream = []; downstream = []; dirty = false; + outbound_inflight = 0; process; stats; } in Hashtbl.replace nodes name info; + sorted_valid := false; info let add_edge ~from_name ~to_name ~label = @@ -136,18 +118,41 @@ 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 reset_stats () = Hashtbl.iter @@ -339,61 +344,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,55 +380,88 @@ 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; + subscribe: (('k, 'v) wave -> unit) -> unit; iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v option; + get: 'k -> 'v ReactiveMaybe.t; length: unit -> int; stats: stats; level: int; + node: Registry.node_info; } let iter f t = t.iter f @@ -462,69 +473,71 @@ let name t = t.name (** {1 Source Collection} *) +(* Module-level helper for source emit — avoids closure allocation. + Groups tbl + pending so iter_with can pass a single argument. *) +type ('k, 'v) source_tables = { + tbl: ('k, 'v) ReactiveHash.Map.t; + pending: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; +} + +let apply_source_emit (tables : ('k, 'v) source_tables) k + (mv : 'v ReactiveMaybe.t) = + if ReactiveMaybe.is_some mv then ( + let v = ReactiveMaybe.unsafe_get mv in + ReactiveHash.Map.replace tables.tbl k v; + ReactiveHash.Map.replace tables.pending k (ReactiveMaybe.some v)) + else ( + ReactiveHash.Map.remove tables.tbl k; + ReactiveHash.Map.replace tables.pending k ReactiveMaybe.none) + let source ~name () = - let tbl = Hashtbl.create 64 in + let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.create () in let subscribers = ref [] in let my_stats = create_stats () in - - (* Pending deltas to propagate *) - let pending = ref [] in + let output_wave = create_wave () in + (* Pending deltas: accumulated by emit, flushed by process. + Uses ReactiveHash.Map for zero-alloc deduplication (last-write-wins). *) + let pending : ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () + in + let tables = {tbl; pending} in + let pending_count = ref 0 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 - 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)) + let count = ReactiveHash.Map.cardinal pending in + if count > 0 then ( + my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; + my_stats.entries_emitted <- my_stats.entries_emitted + count; + ReactiveWave.clear output_wave; + ReactiveHash.Map.iter_with ReactiveWave.push output_wave pending; + ReactiveHash.Map.clear pending; + notify_subscribers output_wave !subscribers) + else ReactiveHash.Map.clear pending in - let _info = Registry.register ~name ~level:0 ~process ~stats:my_stats in + let my_info = Registry.register ~name ~level:0 ~process ~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); + iter = (fun f -> ReactiveHash.Map.iter f tbl); + get = (fun k -> ReactiveHash.Map.find_maybe tbl k); + length = (fun () -> ReactiveHash.Map.cardinal tbl); stats = my_stats; level = 0; + node = my_info; } in - let emit delta = - (* Track input *) + let emit (input_wave : ('k, 'v ReactiveMaybe.t) ReactiveWave.t) = + let count = ReactiveWave.count input_wave in 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 *) + my_stats.entries_received <- my_stats.entries_received + count; + (* Apply to internal state and accumulate into pending map *) + ReactiveWave.iter_with input_wave apply_source_emit tables; + pending_count := !pending_count + 1; + Registry.mark_dirty_node my_info; if not (Scheduler.is_propagating ()) then Scheduler.propagate () in @@ -540,155 +553,57 @@ let flatMap ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = | 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 output_wave = create_wave () in let my_stats = create_stats () in + let state = ReactiveFlatMap.create ~f ~merge:merge_fn ~output_wave in + let pending_count = ref 0 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 process () = + let consumed = !pending_count in + pending_count := 0; - 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 + my_stats.deltas_received <- my_stats.deltas_received + consumed; - 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 + Registry.dec_inflight_node src.node consumed; - 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 - 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 r = ReactiveFlatMap.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; - 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 := []; - 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.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)) + if r.entries_emitted > 0 then ( + 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 - let _info = + let my_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); + (* Subscribe to source: push directly into pending map *) + src.subscribe (fun wave -> + Registry.inc_inflight_node src.node; + incr pending_count; + ReactiveWave.iter_with wave ReactiveFlatMap.push state; + Registry.mark_dirty_node my_info); (* 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); + src.iter (fun k v -> ReactiveFlatMap.init_entry 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); + iter = (fun f -> ReactiveFlatMap.iter_target f state); + get = (fun k -> ReactiveFlatMap.find_target state k); + length = (fun () -> ReactiveFlatMap.target_length state); stats = my_stats; level = my_level; + node = my_info; } (** {1 Join} *) @@ -702,197 +617,42 @@ let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () | 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 output_wave = create_wave () 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 + let state = + ReactiveJoin.create ~key_of ~f ~merge:merge_fn ~right_get:right.get + ~output_wave in + let left_pending_count = ref 0 in + let right_pending_count = ref 0 in let process () = - (* Track input deltas *) + 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 + List.length !left_pending - + List.length !right_pending; + my_stats.deltas_received + consumed_left + consumed_right; - (* Process both left and right pending *) - let left_entries_list = - !left_pending |> List.concat_map delta_to_entries |> merge_entries - in - let right_entries_list = - !right_pending |> List.concat_map delta_to_entries |> merge_entries - in - left_pending := []; - right_pending := []; + Registry.dec_inflight_node left.node consumed_left; + Registry.dec_inflight_node right.node consumed_right; - 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)) - in + 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 output_entries <> [] then ( - let num_adds, num_removes = count_changes output_entries in + if r.entries_emitted > 0 then ( 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) + 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 - let _info = + let my_info = Registry.register ~name ~level:my_level ~process ~stats:my_stats in Registry.add_edge ~from_name:left.name ~to_name:name ~label:"join"; @@ -900,29 +660,31 @@ let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () 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); + (* Subscribe to sources: push directly into pending maps *) + left.subscribe (fun wave -> + Registry.inc_inflight_node left.node; + incr left_pending_count; + ReactiveWave.iter_with wave ReactiveJoin.push_left state; + Registry.mark_dirty_node my_info); - right.subscribe (fun delta -> - right_pending := delta :: !right_pending; - Registry.mark_dirty name); + right.subscribe (fun wave -> + Registry.inc_inflight_node right.node; + incr right_pending_count; + ReactiveWave.iter_with wave ReactiveJoin.push_right state; + Registry.mark_dirty_node my_info); (* Initialize from existing data *) - left.iter (fun k1 v1 -> - Hashtbl.replace left_entries k1 v1; - let _ = process_left_entry k1 v1 in - ()); + 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); + iter = (fun f -> ReactiveJoin.iter_target f state); + get = (fun k -> ReactiveJoin.find_target state k); + length = (fun () -> ReactiveJoin.target_length state); stats = my_stats; level = my_level; + node = my_info; } (** {1 Union} *) @@ -936,98 +698,39 @@ let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t | 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 output_wave = create_wave () 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 state = ReactiveUnion.create ~merge:merge_fn ~output_wave in + let left_pending_count = ref 0 in + let right_pending_count = ref 0 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 - in - let right_entries = - !right_pending |> List.concat_map delta_to_entries |> merge_entries - in - left_pending := []; - right_pending := []; + let consumed_left = !left_pending_count in + let consumed_right = !right_pending_count in + left_pending_count := 0; + right_pending_count := 0; - 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; + my_stats.deltas_received <- + my_stats.deltas_received + consumed_left + consumed_right; - let all_affected = ref [] in + Registry.dec_inflight_node left.node consumed_left; + Registry.dec_inflight_node right.node consumed_right; - (* 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)) - in + 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 output_entries <> [] then ( - let num_adds, num_removes = count_changes output_entries in + if r.entries_emitted > 0 then ( 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) + 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 - let _info = + let my_info = Registry.register ~name ~level:my_level ~process ~stats:my_stats in Registry.add_edge ~from_name:left.name ~to_name:name ~label:"union"; @@ -1035,39 +738,32 @@ let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t 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); + (* Subscribe to sources: push directly into pending maps *) + left.subscribe (fun wave -> + Registry.inc_inflight_node left.node; + incr left_pending_count; + ReactiveWave.iter_with wave ReactiveUnion.push_left state; + Registry.mark_dirty_node my_info); - right.subscribe (fun delta -> - right_pending := delta :: !right_pending; - Registry.mark_dirty name); + right.subscribe (fun wave -> + Registry.inc_inflight_node right.node; + incr right_pending_count; + ReactiveWave.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 -> - 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); + 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); + iter = (fun f -> ReactiveUnion.iter_target f state); + get = (fun k -> ReactiveUnion.find_target state k); + length = (fun () -> ReactiveUnion.target_length state); stats = my_stats; level = my_level; + node = my_info; } (** {1 Fixpoint} *) @@ -1075,59 +771,75 @@ let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t 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 + 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 (* Internal state *) - let state = ReactiveFixpoint.create () in + 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 + let max_root_wave_entries = + int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_ROOT_WAVE_ENTRIES" 4_096 + 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 = ReactiveWave.create ~max_entries:max_root_wave_entries in + let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries 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) + let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () + in + let edge_pending : ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () in + let init_pending_count = ref 0 in + let edges_pending_count = ref 0 in let process () = - (* Track input deltas *) - my_stats.deltas_received <- - my_stats.deltas_received + List.length !init_pending - + List.length !edges_pending; + let consumed_init = !init_pending_count in + let consumed_edges = !edges_pending_count in + init_pending_count := 0; + edges_pending_count := 0; - let init_entries = - !init_pending |> List.concat_map delta_to_entries |> merge_entries - in - let edges_entries = - !edges_pending |> List.concat_map delta_to_entries |> merge_entries - in - init_pending := []; - edges_pending := []; + 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 *) + ReactiveWave.clear root_wave; + ReactiveWave.clear edge_wave; + let root_entries = ReactiveHash.Map.cardinal root_pending in + let edge_entries = ReactiveHash.Map.cardinal edge_pending in + ReactiveHash.Map.iter_with ReactiveWave.push root_wave root_pending; + ReactiveHash.Map.iter_with ReactiveWave.push edge_wave edge_pending; + ReactiveHash.Map.clear root_pending; + ReactiveHash.Map.clear edge_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 + my_stats.entries_received + root_entries + edge_entries; + my_stats.adds_received <- + my_stats.adds_received + root_entries + edge_entries; + + let out_wave = + ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave in - emit_output output_entries + let out_count = ReactiveWave.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 - let _info = + let my_info = Registry.register ~name ~level:my_level ~process ~stats:my_stats in Registry.add_edge ~from_name:init.name ~to_name:name ~label:"roots"; @@ -1135,17 +847,32 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : Registry.add_combinator ~name:(name ^ "_fp") ~shape:"fixpoint" ~inputs:[init.name; edges.name] ~output:name; - (* Subscribe to sources: just accumulate *) - init.subscribe (fun delta -> - init_pending := delta :: !init_pending; - Registry.mark_dirty 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; + ReactiveWave.iter_with wave ReactiveHash.Map.replace root_pending; + Registry.mark_dirty_node my_info); - edges.subscribe (fun delta -> - edges_pending := delta :: !edges_pending; - Registry.mark_dirty name); + edges.subscribe (fun wave -> + Registry.inc_inflight_node edges.node; + edges_pending_count := !edges_pending_count + 1; + ReactiveWave.iter_with wave ReactiveHash.Map.replace edge_pending; + Registry.mark_dirty_node my_info); (* Initialize from existing data *) - ReactiveFixpoint.initialize state ~roots_iter:init.iter ~edges_iter:edges.iter; + let init_roots_wave = + ReactiveWave.create ~max_entries:(max 1 (init.length ())) + in + let init_edges_wave = + ReactiveWave.create ~max_entries:(max 1 (edges.length ())) + in + ReactiveWave.clear init_roots_wave; + ReactiveWave.clear init_edges_wave; + init.iter (fun k () -> ReactiveWave.push init_roots_wave k ()); + edges.iter (fun k succs -> ReactiveWave.push init_edges_wave k succs); + ReactiveFixpoint.initialize state ~roots:init_roots_wave + ~edges:init_edges_wave; { name; @@ -1155,6 +882,7 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : length = (fun () -> ReactiveFixpoint.current_length state); stats = my_stats; level = my_level; + node = my_info; } (** {1 Utilities} *) diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index cadaecc9691..df1da0cc674 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 ReactiveMaybe.t) ReactiveWave.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; @@ -84,17 +71,18 @@ end type ('k, 'v) t = { name: string; - subscribe: (('k, 'v) delta -> unit) -> unit; + subscribe: (('k, 'v) wave -> unit) -> unit; iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v option; + get: 'k -> 'v ReactiveMaybe.t; length: unit -> int; 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 get : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t val length : ('k, 'v) t -> int val stats : ('k, 'v) t -> stats val level : ('k, 'v) t -> int @@ -102,9 +90,14 @@ val name : ('k, 'v) t -> string (** {1 Source Collection} *) -val source : name:string -> unit -> ('k, 'v) t * (('k, 'v) delta -> unit) +val source : + name:string -> + unit -> + ('k, 'v) t * (('k, 'v ReactiveMaybe.t) ReactiveWave.t -> unit) (** Create a named source collection. - Returns the collection and an emit function. + Returns the collection and an emit function that takes a wave. + Each wave entry is a key with [ReactiveMaybe.some v] for set + or [ReactiveMaybe.none] for remove. Emitting triggers propagation through the pipeline. *) (** {1 Combinators} *) @@ -112,7 +105,7 @@ val source : name:string -> unit -> ('k, 'v) t * (('k, 'v) delta -> unit) val flatMap : name:string -> ('k1, 'v1) t -> - f:('k1 -> 'v1 -> ('k2 * 'v2) list) -> + f:('k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> ?merge:('v2 -> 'v2 -> 'v2) -> unit -> ('k2, 'v2) t @@ -124,7 +117,7 @@ val join : ('k1, 'v1) t -> ('k2, 'v2) t -> key_of:('k1 -> 'v1 -> 'k2) -> - f:('k1 -> 'v1 -> 'v2 option -> ('k3 * 'v3) list) -> + f:('k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> ?merge:('v3 -> 'v3 -> 'v3) -> unit -> ('k3, 'v3) t diff --git a/analysis/reactive/src/ReactiveAllocTrace.ml b/analysis/reactive/src/ReactiveAllocTrace.ml new file mode 100644 index 00000000000..9ee266671bf --- /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 bcae68a0b79..ddb207da205 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -23,7 +23,8 @@ 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 ReactiveMaybe.t) ReactiveWave.t -> unit; + scratch_wave: (string, 'v ReactiveMaybe.t) ReactiveWave.t; } (** A file collection is just a Reactive.t with some extra operations *) @@ -31,13 +32,17 @@ type ('raw, 'v) t = { 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 scratch_wave = ReactiveWave.create ~max_entries:65_536 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 = + ReactiveWave.clear t.scratch_wave; + ReactiveWave.push t.scratch_wave path (ReactiveMaybe.some value); + t.emit t.scratch_wave (** Process a file if changed. Emits delta to subscribers. *) let process_if_changed t path = @@ -49,51 +54,53 @@ 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 + ReactiveWave.clear t.scratch_wave; + let count = ref 0 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); + ReactiveWave.push t.scratch_wave path (ReactiveMaybe.some value); + incr count) + paths; + if !count > 0 then t.emit t.scratch_wave; + !count (** Remove a file *) let remove t path = Hashtbl.remove t.internal.cache path; - emit t (Reactive.Remove path) + ReactiveWave.clear t.scratch_wave; + ReactiveWave.push t.scratch_wave path ReactiveMaybe.none; + 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 + ReactiveWave.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; + ReactiveWave.push t.scratch_wave path ReactiveMaybe.none; + 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 diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index c3f153e1272..f180f19e92d 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -1,64 +1,97 @@ -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; +(** [list_iter_with f arg xs] calls [f arg x] for each [x] in [xs]. + Unlike [List.iter (f arg) xs], this avoids allocating a closure + when [f] is a top-level function. *) +let rec list_iter_with f arg = function + | [] -> () + | x :: rest -> + f arg x; + list_iter_with f arg rest + +(* Note on set representations: + [current] and [roots] stay as map-of-unit because they are updated as + first-class maps in multiple places. [pred_map] is represented by + [ReactivePoolMapSet] 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, unit) ReactiveHash.Map.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, unit) ReactiveHash.Map.t; + edge_map: ('k, 'k list) ReactiveHash.Map.t; + pred_map: ('k, 'k) ReactivePoolMapSet.t; + roots: ('k, unit) ReactiveHash.Map.t; + output_wave: ('k, unit ReactiveMaybe.t) ReactiveWave.t; + (* Scratch tables — allocated once, cleared per apply_list call *) + deleted_nodes: ('k, unit) ReactiveHash.Map.t; + rederive_pending: ('k, unit) ReactiveHash.Map.t; + expansion_seen: ('k, unit) ReactiveHash.Map.t; + old_successors_for_changed: ('k, 'k list) ReactiveHash.Map.t; + new_successors_for_changed: ('k, 'k list) ReactiveHash.Map.t; + (* Scratch sets for analyze_edge_change / apply_edge_update *) + scratch_set_a: 'k ReactiveHash.Set.t; + scratch_set_b: 'k ReactiveHash.Set.t; + edge_has_new: 'k ReactiveHash.Set.t; + (* Scratch queues *) + delete_queue: 'k ReactiveQueue.t; + rederive_queue: 'k ReactiveQueue.t; + expansion_queue: 'k ReactiveQueue.t; + added_roots_queue: 'k ReactiveQueue.t; + edge_change_queue: 'k ReactiveQueue.t; + metrics: 'k metrics_state; } -let analyze_edge_change ~old_succs ~new_succs = +(* Standalone version for Invariants (no scratch sets available). + Debug-only — allocates temporary Hashtbl. *) +let analyze_edge_change_has_new ~old_succs ~new_succs = match (old_succs, new_succs) with - | [], [] -> ([], false) - | [], _ -> ([], true) - | _, [] -> (old_succs, false) + | [], [] -> false + | [], _ -> true + | _, [] -> 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 + List.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs + +(* 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_root visited frontier _t k () = + ReactiveHash.Map.replace visited k (); + ReactiveQueue.push frontier k + +let bfs_visit_succ visited frontier succ = + if not (ReactiveHash.Map.mem visited succ) then ( + ReactiveHash.Map.replace visited succ (); + ReactiveQueue.push frontier succ) + +let compute_reachable ~visited t = + ReactiveHash.Map.clear visited; + let frontier = t.delete_queue in + ReactiveQueue.clear frontier; + let node_work = ref 0 in + let edge_work = ref 0 in + ReactiveHash.Map.iter_with (bfs_seed_root visited frontier) t t.roots; + while not (ReactiveQueue.is_empty frontier) do + let k = ReactiveQueue.pop frontier in + incr node_work; + let r = ReactiveHash.Map.find_maybe t.edge_map k in + if ReactiveMaybe.is_some r then ( + let succs = ReactiveMaybe.unsafe_get r in + edge_work := !edge_work + List.length succs; + list_iter_with (bfs_visit_succ visited) frontier succs) done; - (new_current, !nodes_visited, !edges_scanned) + (!node_work, !edge_work) module Metrics = struct let enabled = @@ -103,6 +136,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,9 +232,11 @@ 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; + (* Debug-only: copies a ReactiveHash.Map set into a Hashtbl for diffing. + These allocations are acceptable since Invariants is opt-in debug code. *) + let copy_rh_set_to_hashtbl (rh : ('k, unit) ReactiveHash.Map.t) = + let out = Hashtbl.create (ReactiveHash.Map.cardinal rh) in + ReactiveHash.Map.iter (fun k () -> Hashtbl.replace out k ()) rh; out let set_equal a b = @@ -201,111 +246,136 @@ module Invariants = struct 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)]. *) - if enabled then + let assert_edge_has_new_consistent ~edge_change_queue + ~old_successors_for_changed ~new_successors_for_changed ~edge_has_new = + if enabled then ( + let q_copy = ReactiveQueue.create () in + (* Drain and re-push to iterate without consuming *) + let items = ref [] in + while not (ReactiveQueue.is_empty edge_change_queue) do + let src = ReactiveQueue.pop edge_change_queue in + items := src :: !items; + ReactiveQueue.push q_copy src + done; + (* Restore queue *) 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 + (fun src -> ReactiveQueue.push edge_change_queue src) + (List.rev !items); + (* Check each *) + List.iter + (fun src -> + let r_old = + ReactiveHash.Map.find_maybe old_successors_for_changed src + in + let old_succs = + if ReactiveMaybe.is_some r_old then ReactiveMaybe.unsafe_get r_old + else [] + in + let r_new = + ReactiveHash.Map.find_maybe new_successors_for_changed src + in + let new_succs = + if ReactiveMaybe.is_some r_new then ReactiveMaybe.unsafe_get r_new + else [] in + let expected_has_new = + analyze_edge_change_has_new ~old_succs ~new_succs + in + let actual_has_new = ReactiveHash.Set.mem edge_has_new src in assert_ - (removed_targets = expected_removed - && has_new_edge = expected_has_new) - "ReactiveFixpoint.apply invariant failed: inconsistent edge_change") - edge_changes + (expected_has_new = actual_has_new) + "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") + !items) 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]. *) if enabled then - Hashtbl.iter + ReactiveHash.Map.iter (fun k () -> - assert_ (Hashtbl.mem current k) + assert_ + (ReactiveHash.Map.mem current k) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; List.iter (fun succ -> - if Hashtbl.mem current succ then + if ReactiveHash.Map.mem current succ then assert_ - (Hashtbl.mem deleted_nodes succ) + (ReactiveHash.Map.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; - assert_ - (set_equal expected 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 + ReactiveHash.Map.iter (fun k () -> - if not (Hashtbl.mem current k) then + if not (ReactiveHash.Map.mem current k) then assert_ (not (supported k)) "ReactiveFixpoint.apply invariant failed: supported deleted node \ left behind") deleted_nodes + let assert_current_minus_deleted ~pre_current ~current ~deleted_nodes = + if enabled then ( + let expected = Hashtbl.copy pre_current in + ReactiveHash.Map.iter + (fun k () -> Hashtbl.remove expected k) + deleted_nodes; + let current_ht = copy_rh_set_to_hashtbl current in + assert_ + (set_equal expected current_ht) + "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ + deleted") + 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 + let expected = Hashtbl.create (ReactiveHash.Map.cardinal deleted_nodes) in + ReactiveHash.Map.iter (fun k () -> - if not (Hashtbl.mem current k) then Hashtbl.replace expected k ()) + if not (ReactiveHash.Map.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 ()) + (fun (k, mv) -> + if not (ReactiveMaybe.is_some mv) then Hashtbl.replace actual k ()) output_entries; assert_ (set_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]. *) + let assert_final_fixpoint_and_delta ~visited ~t ~pre_current ~output_entries = if enabled then ( - let reachable = compute_reachable t in + ignore (compute_reachable ~visited t); + let reachable = copy_rh_set_to_hashtbl visited in + let current_ht = copy_rh_set_to_hashtbl t.current in assert_ - (set_equal reachable t.current) + (set_equal reachable current_ht) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; - let expected_adds = Hashtbl.create (Hashtbl.length t.current) in + let expected_adds = + Hashtbl.create (ReactiveHash.Map.cardinal t.current) + in let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in - Hashtbl.iter + ReactiveHash.Map.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 + if not (ReactiveHash.Map.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 ()) + (fun (k, mv) -> + if ReactiveMaybe.is_some mv then Hashtbl.replace actual_adds k () + else Hashtbl.replace actual_removes k ()) output_entries; let adds_ok = set_equal expected_adds actual_adds in @@ -317,7 +387,7 @@ module Invariants = struct (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) + (ReactiveHash.Map.cardinal t.current) (List.length output_entries) (Hashtbl.length expected_adds) (Hashtbl.length actual_adds) @@ -325,312 +395,378 @@ module Invariants = struct (Hashtbl.length actual_removes))) 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 = ReactiveHash.Map.create (); + edge_map = ReactiveHash.Map.create (); + pred_map = ReactivePoolMapSet.create ~capacity:128; + roots = ReactiveHash.Map.create (); + output_wave = ReactiveWave.create ~max_entries:max_nodes; + deleted_nodes = ReactiveHash.Map.create (); + rederive_pending = ReactiveHash.Map.create (); + expansion_seen = ReactiveHash.Map.create (); + old_successors_for_changed = ReactiveHash.Map.create (); + scratch_set_a = ReactiveHash.Set.create (); + scratch_set_b = ReactiveHash.Set.create (); + edge_has_new = ReactiveHash.Set.create (); + delete_queue = ReactiveQueue.create (); + rederive_queue = ReactiveQueue.create (); + expansion_queue = ReactiveQueue.create (); + added_roots_queue = ReactiveQueue.create (); + edge_change_queue = ReactiveQueue.create (); + new_successors_for_changed = ReactiveHash.Map.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 = ReactiveHash.Map.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 () +type 'k root_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t +type 'k edge_wave = ('k, 'k list ReactiveMaybe.t) ReactiveWave.t +type 'k output_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t +type 'k root_snapshot = ('k, unit) ReactiveWave.t +type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t + +let iter_current t f = ReactiveHash.Map.iter f t.current +let get_current t k = ReactiveHash.Map.find_maybe t.current k +let current_length t = ReactiveHash.Map.cardinal t.current + +let recompute_current t = ignore (compute_reachable ~visited:t.current t) + +let add_pred t ~target ~pred = ReactivePoolMapSet.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 + ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred -exception Found_live_pred +let has_live_pred_key t pred = ReactiveHash.Map.mem t.current 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 r = ReactivePoolMapSet.find_maybe t.pred_map k in + if ReactiveMaybe.is_some r then + ReactiveHash.Set.exists_with has_live_pred_key t + (ReactiveMaybe.unsafe_get r) + else false let apply_edge_update t ~src ~new_successors = + let r = ReactiveHash.Map.find_maybe t.edge_map src in let old_successors = - match Hashtbl.find_opt t.edge_map src with - | Some succs -> succs - | None -> [] + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] in match (old_successors, new_successors) with - | [], [] -> Hashtbl.remove t.edge_map src + | [], [] -> ReactiveHash.Map.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 + ReactiveHash.Map.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 + ReactiveHash.Map.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; + ReactiveHash.Set.clear t.scratch_set_a; + ReactiveHash.Set.clear t.scratch_set_b; + List.iter (fun k -> ReactiveHash.Set.add t.scratch_set_a k) new_successors; + List.iter (fun k -> ReactiveHash.Set.add t.scratch_set_b k) old_successors; List.iter (fun target -> - if not (Hashtbl.mem new_set target) then remove_pred t ~target ~pred:src) + if not (ReactiveHash.Set.mem t.scratch_set_a 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) + if not (ReactiveHash.Set.mem t.scratch_set_b target) then + add_pred t ~target ~pred:src) new_successors; - Hashtbl.replace t.edge_map src new_successors + ReactiveHash.Map.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 -> +let initialize t ~roots ~edges = + ReactiveHash.Map.clear t.roots; + ReactiveHash.Map.clear t.edge_map; + ReactivePoolMapSet.clear t.pred_map; + ReactiveWave.iter roots (fun k () -> ReactiveHash.Map.replace t.roots k ()); + ReactiveWave.iter edges (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 pre_current = - if Invariants.enabled then Some (Invariants.copy_set t.current) else None + recompute_current t + +let is_supported t k = + ReactiveHash.Map.mem t.roots k || has_live_predecessor t k + +let old_successors t k = + let r = ReactiveHash.Map.find_maybe t.old_successors_for_changed k in + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r + else + let r2 = ReactiveHash.Map.find_maybe t.edge_map k in + if ReactiveMaybe.is_some r2 then ReactiveMaybe.unsafe_get r2 else [] + +let mark_deleted t k = + if + ReactiveHash.Map.mem t.current k + && not (ReactiveHash.Map.mem t.deleted_nodes k) + then ( + ReactiveHash.Map.replace t.deleted_nodes k (); + ReactiveQueue.push t.delete_queue k) + +let enqueue_expand t k = + if + ReactiveHash.Map.mem t.current k + && not (ReactiveHash.Map.mem t.expansion_seen k) + then ( + ReactiveHash.Map.replace t.expansion_seen k (); + ReactiveQueue.push t.expansion_queue k) + +let add_live t k = + if not (ReactiveHash.Map.mem t.current k) then ( + ReactiveHash.Map.replace t.current k (); + if not (ReactiveHash.Map.mem t.deleted_nodes k) then + ReactiveWave.push t.output_wave k (ReactiveMaybe.some ()); + enqueue_expand t k) + +let enqueue_rederive_if_needed t k = + if + ReactiveHash.Map.mem t.deleted_nodes k + && (not (ReactiveHash.Map.mem t.current k)) + && (not (ReactiveHash.Map.mem t.rederive_pending k)) + && is_supported t k + then ( + ReactiveHash.Map.replace t.rederive_pending k (); + ReactiveQueue.push t.rederive_queue k) + +let scan_root_entry t k mv = + let had_root = ReactiveHash.Map.mem t.roots k in + if ReactiveMaybe.is_some mv then ( + if not had_root then ReactiveQueue.push t.added_roots_queue k) + else if had_root then mark_deleted t k + +let set_add_k set k = ReactiveHash.Set.add set k + +let rec mark_deleted_unless_in_set t set = function + | [] -> () + | k :: rest -> + if not (ReactiveHash.Set.mem set k) then mark_deleted t k; + mark_deleted_unless_in_set t set rest + +let rec list_exists_not_in_set set = function + | [] -> false + | k :: rest -> + (not (ReactiveHash.Set.mem set k)) || list_exists_not_in_set set rest + +let scan_edge_entry t src mv = + let r = ReactiveHash.Map.find_maybe t.edge_map src in + let old_succs = + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] 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 new_succs = + if ReactiveMaybe.is_some mv then ReactiveMaybe.unsafe_get mv else [] in + ReactiveHash.Map.replace t.old_successors_for_changed src old_succs; + ReactiveHash.Map.replace t.new_successors_for_changed src new_succs; + ReactiveQueue.push t.edge_change_queue src; + let src_is_live = ReactiveHash.Map.mem t.current src in + match (old_succs, new_succs) with + | [], [] -> () + | [], _ -> ReactiveHash.Set.add t.edge_has_new src + | _, [] -> if src_is_live then list_iter_with mark_deleted t old_succs + | _, _ -> + ReactiveHash.Set.clear t.scratch_set_a; + ReactiveHash.Set.clear t.scratch_set_b; + list_iter_with set_add_k t.scratch_set_a new_succs; + list_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 list_exists_not_in_set t.scratch_set_b new_succs then + ReactiveHash.Set.add t.edge_has_new src - 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) - in +let apply_root_mutation t k mv = + if ReactiveMaybe.is_some mv then ReactiveHash.Map.replace t.roots k () + else ReactiveHash.Map.remove t.roots k - 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 +let emit_removal t k () = + if not (ReactiveHash.Map.mem t.current k) then + ReactiveWave.push t.output_wave k ReactiveMaybe.none + +let rebuild_edge_change_queue t src _succs = + ReactiveQueue.push t.edge_change_queue src + +let remove_from_current t k () = ReactiveHash.Map.remove t.current k + +let enqueue_rederive_if_needed_kv t k () = enqueue_rederive_if_needed t k - 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 +let apply_list t ~roots ~edges = + let pre_current = + if Invariants.enabled then + Some (Invariants.copy_rh_set_to_hashtbl t.current) + else None + in + (* Clear all scratch state up front *) + ReactiveHash.Map.clear t.deleted_nodes; + ReactiveQueue.clear t.delete_queue; + ReactiveQueue.clear t.added_roots_queue; + ReactiveQueue.clear t.edge_change_queue; + ReactiveHash.Map.clear t.old_successors_for_changed; + ReactiveHash.Map.clear t.new_successors_for_changed; + ReactiveHash.Set.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 *) + ReactiveWave.iter_with roots scan_root_entry t; + + (* Phase 1b: scan edge entries — seed delete queue for removed targets, + store new_succs and has_new_edge for later phases *) + ReactiveWave.iter_with edges scan_edge_entry t; + + Invariants.assert_edge_has_new_consistent + ~edge_change_queue:t.edge_change_queue + ~old_successors_for_changed:t.old_successors_for_changed + ~new_successors_for_changed:t.new_successors_for_changed + ~edge_has_new:t.edge_has_new; + + (* Phase 2: delete BFS *) + while not (ReactiveQueue.is_empty t.delete_queue) do + let k = ReactiveQueue.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 + List.length succs); + list_iter_with mark_deleted t 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; + if Invariants.enabled then + Invariants.assert_deleted_nodes_closed ~current:t.current + ~deleted_nodes:t.deleted_nodes ~old_successors:(old_successors t); + + (* Phase 3: apply root and edge mutations *) + ReactiveWave.iter_with roots apply_root_mutation t; + + (* Apply edge updates by draining edge_change_queue. *) + while not (ReactiveQueue.is_empty t.edge_change_queue) do + let src = ReactiveQueue.pop t.edge_change_queue in + let r = ReactiveHash.Map.find_maybe t.new_successors_for_changed src in + let new_succs = + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] + 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 *) + ReactiveHash.Map.iter_with rebuild_edge_change_queue t + t.new_successors_for_changed; + + ReactiveHash.Map.iter_with remove_from_current t t.deleted_nodes; (match pre_current with | Some pre -> Invariants.assert_current_minus_deleted ~pre_current:pre ~current:t.current - ~deleted_nodes + ~deleted_nodes:t.deleted_nodes | None -> ()); - let supported k = Hashtbl.mem t.roots k || has_live_predecessor t k in + (* Phase 4: rederive *) + ReactiveQueue.clear t.rederive_queue; + ReactiveHash.Map.clear t.rederive_pending; - 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 + ReactiveHash.Map.iter_with enqueue_rederive_if_needed_kv t t.deleted_nodes; - let enqueue_rederive_if_needed k = + while not (ReactiveQueue.is_empty t.rederive_queue) do + let k = ReactiveQueue.pop t.rederive_queue in + if Metrics.enabled then m.rederive_queue_pops <- m.rederive_queue_pops + 1; + ReactiveHash.Map.remove t.rederive_pending k; if - Hashtbl.mem deleted_nodes k - && (not (Hashtbl.mem t.current k)) - && (not (Hashtbl.mem rederive_pending k)) - && supported k + ReactiveHash.Map.mem t.deleted_nodes k + && (not (ReactiveHash.Map.mem t.current k)) + && is_supported t k then ( - Hashtbl.replace rederive_pending k (); - Queue.add k rederive_queue) - in + ReactiveHash.Map.replace t.current k (); + if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; + let r = ReactiveHash.Map.find_maybe t.edge_map k in + if ReactiveMaybe.is_some r then ( + let succs = ReactiveMaybe.unsafe_get r in + if Metrics.enabled then + m.rederive_edges_scanned <- + m.rederive_edges_scanned + List.length succs; + list_iter_with enqueue_rederive_if_needed t succs)) + done; + if Invariants.enabled then + Invariants.assert_no_supported_deleted_left ~deleted_nodes:t.deleted_nodes + ~current:t.current ~supported:(is_supported t); - Hashtbl.iter (fun k () -> enqueue_rederive_if_needed k) deleted_nodes; + (* Phase 5: expansion *) + ReactiveQueue.clear t.expansion_queue; + ReactiveHash.Map.clear t.expansion_seen; - while not (Queue.is_empty rederive_queue) do - let k = Queue.pop rederive_queue in - incr rederive_queue_pops; - Hashtbl.remove rederive_pending k; - if - Hashtbl.mem deleted_nodes k - && (not (Hashtbl.mem t.current k)) - && supported 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) + (* Seed expansion from added roots *) + while not (ReactiveQueue.is_empty t.added_roots_queue) do + add_live t (ReactiveQueue.pop t.added_roots_queue) 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 - 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 + (* Seed expansion from edge changes with new edges *) + while not (ReactiveQueue.is_empty t.edge_change_queue) do + let src = ReactiveQueue.pop t.edge_change_queue in + if + ReactiveHash.Map.mem t.current src + && ReactiveHash.Set.mem t.edge_has_new src + then enqueue_expand t src + done; - 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 + while not (ReactiveQueue.is_empty t.expansion_queue) do + let k = ReactiveQueue.pop t.expansion_queue in + if Metrics.enabled then m.expansion_queue_pops <- m.expansion_queue_pops + 1; + let r = ReactiveHash.Map.find_maybe t.edge_map k in + if ReactiveMaybe.is_some r then ( + let succs = ReactiveMaybe.unsafe_get r in + if Metrics.enabled then + m.expansion_edges_scanned <- + m.expansion_edges_scanned + List.length succs; + list_iter_with add_live t succs) 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; + ReactiveHash.Map.iter_with emit_removal t t.deleted_nodes; + let output_entries_list = + if Invariants.enabled then ( + let entries = ref [] in + ReactiveWave.iter t.output_wave (fun k v_opt -> + entries := (k, v_opt) :: !entries); + !entries) + else [] + in + Invariants.assert_removal_output_matches ~output_entries:output_entries_list + ~deleted_nodes:t.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 + ~visited:t.metrics.scratch_reachable ~t ~pre_current:pre + ~output_entries:output_entries_list | 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 + if Metrics.enabled then + let full_node_work, full_edge_work = + compute_reachable ~visited:t.metrics.scratch_reachable t + in + let init_count = ReactiveWave.count roots in + let edge_count = ReactiveWave.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:(ReactiveWave.count t.output_wave) + ~deleted_nodes:(ReactiveHash.Map.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 = + ReactiveWave.clear t.output_wave; + apply_list t ~roots ~edges; + t.output_wave diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 2b68c56ad86..8cee2688f4b 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -1,63 +1,32 @@ 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 ReactiveMaybe.t) ReactiveWave.t +type 'k edge_wave = ('k, 'k list ReactiveMaybe.t) ReactiveWave.t +type 'k output_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t +type 'k root_snapshot = ('k, unit) ReactiveWave.t +type 'k edge_snapshot = ('k, 'k list) ReactiveWave.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. *) - -val get_current : 'k t -> 'k -> unit option -(** Membership query for [C]. - Returns [Some ()] iff the key is currently reachable, [None] otherwise. *) + Raises [Invalid_argument] if capacities are not positive. *) +val iter_current : 'k t -> ('k -> unit -> unit) -> unit +val get_current : 'k t -> 'k -> unit ReactiveMaybe.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 -> 'k output_wave +(** Apply one incremental update wave and return closure delta entries as an + 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 00000000000..d16010061d2 --- /dev/null +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -0,0 +1,152 @@ +(** Zero-allocation (steady-state) flatMap state and processing logic. + + Uses ReactiveHash for persistent state and scratch tables. + After steady-state capacity is reached, the per-process overhead + is zero allocations (emit-callback API, ReactiveHash.Set for + provenance, iter_with for all iterations). *) + +type ('k1, 'v1, 'k2, 'v2) t = { + f: 'k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit; + merge: 'v2 -> 'v2 -> 'v2; + (* Persistent state *) + provenance: ('k1, 'k2) ReactivePoolMapSet.t; + contributions: ('k2, 'k1, 'v2) ReactivePoolMapMap.t; + target: ('k2, 'v2) ReactiveHash.Map.t; + (* Scratch — allocated once, cleared per process() *) + scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveHash.Map.t; + affected: 'k2 ReactiveHash.Set.t; + (* Pre-allocated output buffer *) + output_wave: ('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t; + (* Emit callback state — allocated once, reused per entry *) + mutable current_k1: 'k1; + emit_fn: 'k2 -> 'v2 -> unit; + (* Mutable stats — allocated once, returned by process() *) + result: process_result; + (* Mutable merge state for recompute_target *) + mutable merge_first: bool; + mutable merge_acc: 'v2; +} + +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; +} + +(* Emit callback for steady-state — marks affected *) +let add_single_contribution (t : (_, _, _, _) t) k2 v2 = + ReactivePoolMapSet.add t.provenance t.current_k1 k2; + ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; + ReactiveHash.Set.add t.affected k2 + +(* Emit callback for init — writes directly to target *) +let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = + ReactivePoolMapSet.add t.provenance t.current_k1 k2; + ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; + ReactiveHash.Map.replace t.target k2 v2 + +let create ~f ~merge ~output_wave = + let rec t = + { + f; + merge; + provenance = ReactivePoolMapSet.create ~capacity:128; + contributions = ReactivePoolMapMap.create ~capacity:128; + target = ReactiveHash.Map.create (); + scratch = ReactiveHash.Map.create (); + affected = ReactiveHash.Set.create (); + output_wave; + current_k1 = Obj.magic (); + emit_fn = (fun k2 v2 -> add_single_contribution t k2 v2); + result = + { + entries_received = 0; + adds_received = 0; + removes_received = 0; + entries_emitted = 0; + adds_emitted = 0; + removes_emitted = 0; + }; + merge_first = true; + merge_acc = Obj.magic (); + } + in + t + +let push t k v_opt = ReactiveHash.Map.replace t.scratch k v_opt + +(* Remove one contribution key during remove_source iteration *) +let remove_one_contribution (t : (_, _, _, _) t) k2 = + ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 + t.current_k1; + ReactiveHash.Set.add t.affected k2 + +let remove_source (t : (_, _, _, _) t) k1 = + t.current_k1 <- k1; + ReactivePoolMapSet.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 t.merge_first then ( + t.merge_acc <- v; + t.merge_first <- false) + else t.merge_acc <- t.merge t.merge_acc v + +let recompute_target (t : (_, _, _, _) t) k2 = + if ReactivePoolMapMap.inner_cardinal t.contributions k2 > 0 then ( + t.merge_first <- true; + ReactivePoolMapMap.iter_inner_with t.contributions k2 t + merge_one_contribution; + ReactiveHash.Map.replace t.target k2 t.merge_acc; + ReactiveWave.push t.output_wave k2 (ReactiveMaybe.some t.merge_acc)) + else ( + ReactiveHash.Map.remove t.target k2; + ReactiveWave.push t.output_wave k2 ReactiveMaybe.none) + +(* Single-pass process + count for scratch *) +let process_scratch_entry (t : (_, _, _, _) t) k1 mv = + t.result.entries_received <- t.result.entries_received + 1; + remove_source t k1; + if ReactiveMaybe.is_some mv then ( + t.result.adds_received <- t.result.adds_received + 1; + let v1 = ReactiveMaybe.unsafe_get mv in + t.current_k1 <- k1; + t.f k1 v1 t.emit_fn) + else t.result.removes_received <- t.result.removes_received + 1 + +let count_output_entry (r : process_result) _k mv = + if ReactiveMaybe.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; + + ReactiveHash.Set.clear t.affected; + ReactiveWave.clear t.output_wave; + + ReactiveHash.Map.iter_with process_scratch_entry t t.scratch; + ReactiveHash.Map.clear t.scratch; + + ReactiveHash.Set.iter_with recompute_target t t.affected; + + let num_entries = ReactiveWave.count t.output_wave in + r.entries_emitted <- num_entries; + if num_entries > 0 then + ReactiveWave.iter_with t.output_wave count_output_entry r; + r + +let init_entry (t : (_, _, _, _) t) k1 v1 = + t.current_k1 <- k1; + t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) + +let iter_target f t = ReactiveHash.Map.iter f t.target +let find_target t k = ReactiveHash.Map.find_maybe t.target k +let target_length t = ReactiveHash.Map.cardinal t.target diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli new file mode 100644 index 00000000000..65422df1f50 --- /dev/null +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -0,0 +1,35 @@ +(** Zero-allocation (steady-state) flatMap state and processing logic. + + This module is used by {!Reactive.flatMap}. *) + +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 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> + merge:('v2 -> 'v2 -> 'v2) -> + output_wave:('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t -> + ('k1, 'v1, 'k2, 'v2) t + +val push : ('k1, 'v1, 'k2, 'v2) t -> 'k1 -> 'v1 ReactiveMaybe.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 -> 'v1 -> unit +(** Initialize from an existing source entry (during setup). *) + +val iter_target : ('k2 -> 'v2 -> unit) -> ('k1, 'v1, 'k2, 'v2) t -> unit +val find_target : ('k1, 'v1, 'k2, 'v2) t -> 'k2 -> 'v2 ReactiveMaybe.t +val target_length : ('k1, 'v1, 'k2, 'v2) t -> int diff --git a/analysis/reactive/src/ReactiveHash.ml b/analysis/reactive/src/ReactiveHash.ml new file mode 100644 index 00000000000..0aceb2ca29d --- /dev/null +++ b/analysis/reactive/src/ReactiveHash.ml @@ -0,0 +1,434 @@ +(** Zero-allocation (steady-state) open-addressing hash maps and sets. + + Vendored from Hachis (François Pottier, Inria Paris). + Uses linear probing with void/tomb sentinels, power-of-2 capacity, + and Obj for type erasure. After tables reach steady-state capacity, + [clear] + [replace] cycles perform zero heap allocation. *) + +(* ---- Internal open-addressing table ---- *) + +(* Sentinels: physically unique values that can never be == to any user key. *) +let void = Obj.repr (ref ()) +let tomb = Obj.repr (ref ()) + +let[@inline] is_sentinel c = c == void || c == tomb +let[@inline] is_not_sentinel c = not (is_sentinel c) + +let log_alloc kind before_cap after_cap = + let _ = before_cap in + let _ = after_cap in + ReactiveAllocTrace.emit_alloc_kind kind + +type table = { + mutable population: int; (* number of live keys *) + mutable occupation: int; (* number of live keys + tombstones *) + mutable mask: int; (* capacity - 1 *) + mutable keys: Obj.t array; + mutable vals: Obj.t array; +} + +let initial_capacity = 8 + +(* Max occupancy: 105/128 ≈ 0.82 *) +let max_occupancy = 105 + +let[@inline] capacity t = Array.length t.keys +let[@inline] start t x = Hashtbl.hash x land t.mask +let[@inline] next t j = (j + 1) land t.mask +let[@inline] prev t j = (j - 1) land t.mask + +let[@inline] crowded_or_full occ cap = + 128 * occ > max_occupancy * cap || occ = cap + +let create_table () = + let cap = initial_capacity in + log_alloc ReactiveAllocTrace.Map_create 0 cap; + { + population = 0; + occupation = 0; + mask = cap - 1; + keys = Array.make cap void; + vals = [||]; + } + +let[@inline] ensure_vals t dummy = + if Array.length t.vals = 0 then ( + log_alloc ReactiveAllocTrace.Map_vals_init 0 (capacity t); + t.vals <- Array.make (capacity t) dummy) + +(* Zap slot j: replace with void or tomb, maintaining the invariant + that tomb is never followed by void. *) +let zap t j = + if Array.unsafe_get t.keys (next t j) == void then ( + Array.unsafe_set t.keys j void; + let k = ref (prev t j) in + let count = ref 1 in + while Array.unsafe_get t.keys !k == tomb do + Array.unsafe_set t.keys !k void; + k := prev t !k; + count := !count + 1 + done; + t.occupation <- t.occupation - !count) + else Array.unsafe_set t.keys j tomb + +(* Insert a key known to be absent, with no tombstones present. + Does NOT update population/occupation. Used by resize. *) +let rec add_absent t x v j = + let c = Array.unsafe_get t.keys j in + if c == void then ( + Array.unsafe_set t.keys j x; + Array.unsafe_set t.vals j v) + else add_absent t x v (next t j) + +let resize t new_cap = + log_alloc ReactiveAllocTrace.Table_resize (capacity t) new_cap; + let old_keys = t.keys in + let old_vals = t.vals in + let old_cap = capacity t in + t.mask <- new_cap - 1; + t.keys <- Array.make new_cap void; + (if Array.length old_vals > 0 then + let dummy = Array.unsafe_get old_vals 0 in + t.vals <- Array.make new_cap dummy); + for k = 0 to old_cap - 1 do + let c = Array.unsafe_get old_keys k in + if is_not_sentinel c then + add_absent t c (Array.unsafe_get old_vals k) (start t c) + done; + t.occupation <- t.population + +let[@inline] possibly_grow t = + let o = t.occupation and c = capacity t in + if crowded_or_full o c then resize t (2 * c) + +(* ---- mem ---- *) + +let rec mem_probe t x j = + let c = Array.unsafe_get t.keys j in + if c == void then false + else if c == tomb then mem_probe t x (next t j) + else if c = x then true + else mem_probe t x (next t j) + +let[@inline] table_mem t x = mem_probe t x (start t x) + +(* ---- find_value (raises Not_found) ---- *) + +let rec find_probe t x j = + let c = Array.unsafe_get t.keys j in + if c == void then raise Not_found + else if c == tomb then find_probe t x (next t j) + else if c = x then Array.unsafe_get t.vals j + else find_probe t x (next t j) + +let[@inline] table_find t x = find_probe t x (start t x) + +(* ---- find_maybe (zero-allocation) ---- *) + +let maybe_none_obj : Obj.t = Obj.repr ReactiveMaybe.none + +let rec find_maybe_probe t x j = + let c = Array.unsafe_get t.keys j in + if c == void then maybe_none_obj + else if c == tomb then find_maybe_probe t x (next t j) + else if c = x then Array.unsafe_get t.vals j + else find_maybe_probe t x (next t j) + +let[@inline] table_find_maybe t x = find_maybe_probe t x (start t x) + +(* ---- replace ---- *) + +let rec replace_probe t x v j = + let c = Array.unsafe_get t.keys j in + if c == void then ( + t.occupation <- t.occupation + 1; + ensure_vals t v; + t.population <- t.population + 1; + Array.unsafe_set t.keys j x; + Array.unsafe_set t.vals j v; + true) + else if c == tomb then replace_aux t x v j (next t j) + else if c = x then ( + Array.unsafe_set t.keys j x; + Array.unsafe_set t.vals j v; + false) + else replace_probe t x v (next t j) + +and replace_aux t x v tomb_j j = + let c = Array.unsafe_get t.keys j in + if c == void then ( + (* not found; insert at tombstone slot *) + let j = tomb_j in + t.population <- t.population + 1; + Array.unsafe_set t.keys j x; + Array.unsafe_set t.vals j v; + true) + else if c == tomb then replace_aux t x v tomb_j (next t j) + else if c = x then ( + (* found beyond tombstone; move it back *) + Array.unsafe_set t.keys tomb_j c; + Array.unsafe_set t.vals tomb_j (Array.unsafe_get t.vals j); + zap t j; + let j = tomb_j in + Array.unsafe_set t.keys j x; + Array.unsafe_set t.vals j v; + false) + else replace_aux t x v tomb_j (next t j) + +let table_replace t x v = + let was_added = replace_probe t x v (start t x) in + if was_added then possibly_grow t + +(* ---- remove ---- *) + +let rec remove_probe t x j = + let c = Array.unsafe_get t.keys j in + if c == void then () + else if c == tomb then remove_probe t x (next t j) + else if c = x then ( + t.population <- t.population - 1; + zap t j) + else remove_probe t x (next t j) + +let[@inline] table_remove t x = remove_probe t x (start t x) + +(* ---- find_value_and_remove ---- *) + +let rec find_value_and_remove_probe t x j = + let c = Array.unsafe_get t.keys j in + if c == void then raise Not_found + else if c == tomb then find_value_and_remove_probe t x (next t j) + else if c = x then ( + let v = Array.unsafe_get t.vals j in + t.population <- t.population - 1; + zap t j; + v) + else find_value_and_remove_probe t x (next t j) + +let[@inline] table_find_value_and_remove t x = + find_value_and_remove_probe t x (start t x) + +(* ---- tighten ---- *) + +let rec possibly_shrink t new_cap = + if new_cap = initial_capacity || crowded_or_full t.population (new_cap / 2) + then (if new_cap < capacity t then resize t new_cap) + else possibly_shrink t (new_cap / 2) + +let table_tighten t = possibly_shrink t (capacity t) + +(* ---- clear ---- *) + +let table_clear t = + t.population <- 0; + t.occupation <- 0; + Array.fill t.keys 0 (capacity t) void + +(* ---- iter ---- *) + +let table_iter_kv f t = + if t.population > 0 then + for i = 0 to Array.length t.keys - 1 do + let c = Array.unsafe_get t.keys i in + if is_not_sentinel c then f c (Array.unsafe_get t.vals i) + done + +let table_iter_kv_with f arg t = + if t.population > 0 then + for i = 0 to Array.length t.keys - 1 do + let c = Array.unsafe_get t.keys i in + if is_not_sentinel c then f arg c (Array.unsafe_get t.vals i) + done + +let table_iter_k f t = + if t.population > 0 then + for i = 0 to Array.length t.keys - 1 do + let c = Array.unsafe_get t.keys i in + if is_not_sentinel c then f c + done + +let table_iter_k_with f arg t = + if t.population > 0 then + for i = 0 to Array.length t.keys - 1 do + let c = Array.unsafe_get t.keys i in + if is_not_sentinel c then f arg c + done + +exception Found + +(* ---- exists (early-exit scans) ---- *) + +let table_exists_k p t = + if t.population = 0 then false + else + try + for i = 0 to Array.length t.keys - 1 do + let c = Array.unsafe_get t.keys i in + if is_not_sentinel c && p c then raise Found + done; + false + with Found -> true + +let table_exists_k_with p arg t = + if t.population = 0 then false + else + try + for i = 0 to Array.length t.keys - 1 do + let c = Array.unsafe_get t.keys i in + if is_not_sentinel c && p arg c then raise Found + done; + false + with Found -> true + +(* ---- has_common_key ---- *) + +let table_has_common_key a b = + if a.population = 0 then false + else + try + for i = 0 to Array.length a.keys - 1 do + let c = Array.unsafe_get a.keys i in + if is_not_sentinel c && table_mem b c then raise Found + done; + false + with Found -> true + +(* ---- Set (keys only, no values) ---- *) + +(* For Set we reuse the same table but skip the value array. + We use replace_set which never touches vals. *) + +let rec set_replace_probe t x j = + let c = Array.unsafe_get t.keys j in + if c == void then ( + t.occupation <- t.occupation + 1; + t.population <- t.population + 1; + Array.unsafe_set t.keys j x; + true) + else if c == tomb then set_replace_aux t x j (next t j) + else if c = x then ( + Array.unsafe_set t.keys j x; + false) + else set_replace_probe t x (next t j) + +and set_replace_aux t x tomb_j j = + let c = Array.unsafe_get t.keys j in + if c == void then ( + let j = tomb_j in + t.population <- t.population + 1; + Array.unsafe_set t.keys j x; + true) + else if c == tomb then set_replace_aux t x tomb_j (next t j) + else if c = x then ( + Array.unsafe_set t.keys tomb_j c; + zap t j; + false) + else set_replace_aux t x tomb_j (next t j) + +let set_replace t x = + let was_added = set_replace_probe t x (start t x) in + if was_added then + let o = t.occupation and c = capacity t in + if crowded_or_full o c then ( + (* resize without value array *) + let old_keys = t.keys in + let old_cap = capacity t in + let new_cap = 2 * c in + log_alloc ReactiveAllocTrace.Set_resize c new_cap; + t.mask <- new_cap - 1; + t.keys <- Array.make new_cap void; + for k = 0 to old_cap - 1 do + let c = Array.unsafe_get old_keys k in + if is_not_sentinel c then ( + (* inline add_absent for keys only *) + let j = ref (start t c) in + while Array.unsafe_get t.keys !j != void do + j := next t !j + done; + Array.unsafe_set t.keys !j c) + done; + t.occupation <- t.population) + +let create_set () = + let cap = initial_capacity in + log_alloc ReactiveAllocTrace.Set_create 0 cap; + { + population = 0; + occupation = 0; + mask = cap - 1; + keys = Array.make cap void; + vals = [||]; + } + +(* ==== Public typed API ==== *) + +module Map = struct + type ('k, 'v) t = table + + let create () = create_table () + let clear t = table_clear t + + let replace (type k v) (t : (k, v) t) (k : k) (v : v) = + table_replace t (Obj.repr k) (Obj.repr v) + + let find_opt (type k v) (t : (k, v) t) (k : k) : v option = + match table_find t (Obj.repr k) with + | v -> Some (Obj.obj v : v) + | exception Not_found -> None + + let find (type k v) (t : (k, v) t) (k : k) : v = + (Obj.obj (table_find t (Obj.repr k)) : v) + + let find_maybe (type k v) (t : (k, v) t) (k : k) : v ReactiveMaybe.t = + Obj.obj (table_find_maybe t (Obj.repr k)) + + let mem (type k v) (t : (k, v) t) (k : k) = table_mem t (Obj.repr k) + + let remove (type k v) (t : (k, v) t) (k : k) = table_remove t (Obj.repr k) + + let find_value_and_remove (type k v) (t : (k, v) t) (k : k) : v = + (Obj.obj (table_find_value_and_remove t (Obj.repr k)) : v) + + let tighten t = table_tighten t + + let iter (type k v) (f : k -> v -> unit) (t : (k, v) t) = + table_iter_kv (Obj.magic f : Obj.t -> Obj.t -> unit) t + + let iter_with (type a k v) (f : a -> k -> v -> unit) (arg : a) (t : (k, v) t) + = + table_iter_kv_with + (Obj.magic f : Obj.t -> Obj.t -> Obj.t -> unit) + (Obj.repr arg) t + + let has_common_key (type k v1 v2) (a : (k, v1) t) (b : (k, v2) t) : bool = + table_has_common_key a b + + let cardinal t = t.population +end + +module Set = struct + type 'k t = table + + let create () = create_set () + let clear t = table_clear t + + let add (type k) (t : k t) (k : k) = set_replace t (Obj.repr k) + + let remove (type k) (t : k t) (k : k) = table_remove t (Obj.repr k) + let mem (type k) (t : k t) (k : k) = table_mem t (Obj.repr k) + let tighten t = table_tighten t + + let iter (type k) (f : k -> unit) (t : k t) = + table_iter_k (Obj.magic f : Obj.t -> unit) t + + let iter_with (type a k) (f : a -> k -> unit) (arg : a) (t : k t) = + table_iter_k_with (Obj.magic f : Obj.t -> Obj.t -> unit) (Obj.repr arg) t + + let exists (type k) (p : k -> bool) (t : k t) = + table_exists_k (Obj.magic p : Obj.t -> bool) t + + let exists_with (type a k) (p : a -> k -> bool) (arg : a) (t : k t) = + table_exists_k_with (Obj.magic p : Obj.t -> Obj.t -> bool) (Obj.repr arg) t + + let cardinal t = t.population +end diff --git a/analysis/reactive/src/ReactiveHash.mli b/analysis/reactive/src/ReactiveHash.mli new file mode 100644 index 00000000000..03bc7ca83e6 --- /dev/null +++ b/analysis/reactive/src/ReactiveHash.mli @@ -0,0 +1,63 @@ +(** Zero-allocation (steady-state) open-addressing hash maps and sets. + + Uses linear probing with void/tomb sentinels and Obj for type erasure. + After tables reach steady-state capacity, [clear] + [replace] cycles + perform zero heap allocation. *) + +module Map : sig + type ('k, 'v) t + + val create : unit -> ('k, 'v) t + val clear : ('k, 'v) t -> unit + val replace : ('k, 'v) t -> 'k -> 'v -> unit + val find_opt : ('k, 'v) t -> 'k -> 'v option + val find : ('k, 'v) t -> 'k -> 'v + val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t + val mem : ('k, 'v) t -> 'k -> bool + val remove : ('k, 'v) t -> 'k -> unit + + val find_value_and_remove : ('k, 'v) t -> 'k -> 'v + (** [find_value_and_remove t k] removes [k] and returns its value. + Raises [Not_found] if [k] is absent. *) + + val tighten : ('k, 'v) t -> unit + (** [tighten t] shrinks capacity when occupancy is low. + Call after a batch of removals to reclaim backing-array space. *) + + val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit + + val iter_with : ('a -> 'k -> 'v -> unit) -> 'a -> ('k, 'v) t -> unit + (** [iter_with f arg t] calls [f arg k v] for each binding. + Unlike [iter (f arg) t], avoids allocating a closure when [f] + is a top-level function. Prefer this on hot paths. *) + + val has_common_key : ('k, 'v1) t -> ('k, 'v2) t -> bool + val cardinal : ('k, 'v) t -> int +end + +module Set : sig + type 'k t + + val create : unit -> 'k t + val clear : 'k t -> unit + val add : 'k t -> 'k -> unit + val remove : 'k t -> 'k -> unit + val mem : 'k t -> 'k -> bool + + val tighten : 'k t -> unit + + val iter : ('k -> unit) -> 'k t -> unit + + val iter_with : ('a -> 'k -> unit) -> 'a -> 'k t -> unit + (** See {!Map.iter_with}. *) + + val exists : ('k -> bool) -> 'k t -> bool + (** Returns [true] if any element satisfies the predicate. + Stops scanning as soon as one element matches. *) + + val exists_with : ('a -> 'k -> bool) -> 'a -> 'k t -> bool + (** [exists_with p arg t] is like [exists (p arg) t] but avoids closure + allocation for top-level predicates. *) + + val cardinal : 'k t -> int +end diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml new file mode 100644 index 00000000000..e0b38cfa457 --- /dev/null +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -0,0 +1,214 @@ +(** Zero-allocation (steady-state) join state and processing logic. + + Uses ReactiveHash for persistent state and scratch tables. + After steady-state capacity is reached, the per-process overhead + is zero allocations (emit-callback API, ReactiveHash.Set for + provenance/reverse-index, iter_with for all iterations). *) + +type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { + key_of: 'k1 -> 'v1 -> 'k2; + f: 'k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit; + merge: 'v3 -> 'v3 -> 'v3; + right_get: 'k2 -> 'v2 ReactiveMaybe.t; + (* Persistent state *) + left_entries: ('k1, 'v1) ReactiveHash.Map.t; + provenance: ('k1, 'k3) ReactivePoolMapSet.t; + contributions: ('k3, 'k1, 'v3) ReactivePoolMapMap.t; + target: ('k3, 'v3) ReactiveHash.Map.t; + left_to_right_key: ('k1, 'k2) ReactiveHash.Map.t; + right_key_to_left_keys: ('k2, 'k1) ReactivePoolMapSet.t; + (* Scratch — allocated once, cleared per process() *) + left_scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveHash.Map.t; + right_scratch: ('k2, 'v2 ReactiveMaybe.t) ReactiveHash.Map.t; + affected: 'k3 ReactiveHash.Set.t; + (* Pre-allocated output buffer *) + output_wave: ('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t; + (* Emit callback state — allocated once, reused per entry *) + mutable current_k1: 'k1; + emit_fn: 'k3 -> 'v3 -> unit; + (* Mutable stats — allocated once, returned by process() *) + result: process_result; + (* Mutable merge state for recompute_target *) + mutable merge_first: bool; + mutable merge_acc: 'v3; +} + +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; +} + +(* Emit callback for steady-state — marks affected *) +let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = + ReactivePoolMapSet.add t.provenance t.current_k1 k3; + ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; + ReactiveHash.Set.add t.affected k3 + +(* Emit callback for init — writes directly to target *) +let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = + ReactivePoolMapSet.add t.provenance t.current_k1 k3; + ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; + ReactiveHash.Map.replace t.target k3 v3 + +let create ~key_of ~f ~merge ~right_get ~output_wave = + let rec t = + { + key_of; + f; + merge; + right_get; + left_entries = ReactiveHash.Map.create (); + provenance = ReactivePoolMapSet.create ~capacity:128; + contributions = ReactivePoolMapMap.create ~capacity:128; + target = ReactiveHash.Map.create (); + left_to_right_key = ReactiveHash.Map.create (); + right_key_to_left_keys = ReactivePoolMapSet.create ~capacity:128; + left_scratch = ReactiveHash.Map.create (); + right_scratch = ReactiveHash.Map.create (); + affected = ReactiveHash.Set.create (); + output_wave; + current_k1 = Obj.magic (); + emit_fn = (fun k3 v3 -> add_single_contribution t k3 v3); + result = + { + entries_received = 0; + adds_received = 0; + removes_received = 0; + entries_emitted = 0; + adds_emitted = 0; + removes_emitted = 0; + }; + merge_first = true; + merge_acc = Obj.magic (); + } + in + t + +let push_left t k v_opt = ReactiveHash.Map.replace t.left_scratch k v_opt +let push_right t k v_opt = ReactiveHash.Map.replace t.right_scratch k v_opt + +(* Remove one contribution key during remove_left_contributions iteration *) +let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = + ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 + t.current_k1; + ReactiveHash.Set.add t.affected k3 + +let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = + t.current_k1 <- k1; + ReactivePoolMapSet.drain_key t.provenance k1 t remove_one_contribution_key + +let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = + let mb = ReactiveHash.Map.find_maybe t.left_to_right_key k1 in + if ReactiveMaybe.is_some mb then ( + let old_k2 = ReactiveMaybe.unsafe_get mb in + ReactiveHash.Map.remove t.left_to_right_key k1; + ReactivePoolMapSet.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 + ReactiveHash.Map.replace t.left_to_right_key k1 k2; + ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; + let right_val = t.right_get k2 in + t.current_k1 <- k1; + t.f k1 v1 right_val t.emit_fn + +let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = + ReactiveHash.Map.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 t.merge_first then ( + t.merge_acc <- v; + t.merge_first <- false) + else t.merge_acc <- t.merge t.merge_acc v + +let recompute_target (t : (_, _, _, _, _, _) t) k3 = + if ReactivePoolMapMap.inner_cardinal t.contributions k3 > 0 then ( + t.merge_first <- true; + ReactivePoolMapMap.iter_inner_with t.contributions k3 t + merge_one_contribution; + ReactiveHash.Map.replace t.target k3 t.merge_acc; + ReactiveWave.push t.output_wave k3 (ReactiveMaybe.some t.merge_acc)) + else ( + ReactiveHash.Map.remove t.target k3; + ReactiveWave.push t.output_wave k3 ReactiveMaybe.none) + +(* Single-pass process + count for left scratch *) +let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = + t.result.entries_received <- t.result.entries_received + 1; + if ReactiveMaybe.is_some mv then ( + t.result.adds_received <- t.result.adds_received + 1; + let v1 = ReactiveMaybe.unsafe_get mv in + ReactiveHash.Map.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 = ReactiveHash.Map.find_maybe t.left_entries k1 in + if ReactiveMaybe.is_some mb then + process_left_entry t k1 (ReactiveMaybe.unsafe_get mb) + +(* Single-pass process + count for right scratch *) +let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = + t.result.entries_received <- t.result.entries_received + 1; + if ReactiveMaybe.is_some _mv then + t.result.adds_received <- t.result.adds_received + 1 + else t.result.removes_received <- t.result.removes_received + 1; + let mb = ReactivePoolMapSet.find_maybe t.right_key_to_left_keys k2 in + if ReactiveMaybe.is_some mb then + ReactiveHash.Set.iter_with reprocess_left_entry t + (ReactiveMaybe.unsafe_get mb) + +let count_output_entry (r : process_result) _k mv = + if ReactiveMaybe.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; + + ReactiveHash.Set.clear t.affected; + ReactiveWave.clear t.output_wave; + + ReactiveHash.Map.iter_with process_left_scratch_entry t t.left_scratch; + ReactiveHash.Map.iter_with process_right_scratch_entry t t.right_scratch; + + ReactiveHash.Map.clear t.left_scratch; + ReactiveHash.Map.clear t.right_scratch; + + ReactiveHash.Set.iter_with recompute_target t t.affected; + + let num_entries = ReactiveWave.count t.output_wave in + r.entries_emitted <- num_entries; + if num_entries > 0 then + ReactiveWave.iter_with t.output_wave count_output_entry r; + r + +let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = + ReactiveHash.Map.replace t.left_entries k1 v1; + let k2 = t.key_of k1 v1 in + ReactiveHash.Map.replace t.left_to_right_key k1 k2; + ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; + let right_val = t.right_get k2 in + t.current_k1 <- k1; + t.f k1 v1 right_val (fun k3 v3 -> add_single_contribution_init t k3 v3) + +let iter_target f t = ReactiveHash.Map.iter f t.target +let find_target t k = ReactiveHash.Map.find_maybe t.target k +let target_length t = ReactiveHash.Map.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli new file mode 100644 index 00000000000..2a268454932 --- /dev/null +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -0,0 +1,43 @@ +(** Zero-allocation (steady-state) join state and processing logic. + + This module is used by {!Reactive.join}. *) + +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 -> 'v1 -> 'k2) -> + f:('k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> + merge:('v3 -> 'v3 -> 'v3) -> + right_get:('k2 -> 'v2 ReactiveMaybe.t) -> + output_wave:('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t -> + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t + +val push_left : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k1 -> 'v1 ReactiveMaybe.t -> unit +(** Push an entry into the left scratch table. *) + +val push_right : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k2 -> 'v2 ReactiveMaybe.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 -> 'v1 -> unit +(** Initialize from an existing left source entry (during setup). *) + +val iter_target : + ('k3 -> 'v3 -> unit) -> ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit +val find_target : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k3 -> 'v3 ReactiveMaybe.t +val target_length : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> int diff --git a/analysis/reactive/src/ReactiveMaybe.ml b/analysis/reactive/src/ReactiveMaybe.ml new file mode 100644 index 00000000000..dcc1bca0b63 --- /dev/null +++ b/analysis/reactive/src/ReactiveMaybe.ml @@ -0,0 +1,17 @@ +(** 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 : Obj.t = Obj.repr (ref ()) + +let none = sentinel +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 diff --git a/analysis/reactive/src/ReactiveMaybe.mli b/analysis/reactive/src/ReactiveMaybe.mli new file mode 100644 index 00000000000..d94c0e63394 --- /dev/null +++ b/analysis/reactive/src/ReactiveMaybe.mli @@ -0,0 +1,17 @@ +(** 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 +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 diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml new file mode 100644 index 00000000000..bcb752e18db --- /dev/null +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -0,0 +1,102 @@ +(** A map from outer keys to inner maps, with pooled recycling of inner maps. + + This mirrors the churn-safe API style of [ReactivePoolMapSet] for + map-of-map structures. *) + +type ('ko, 'ki, 'v) t = { + outer: ('ko, ('ki, 'v) ReactiveHash.Map.t) ReactiveHash.Map.t; + mutable pool: ('ki, 'v) ReactiveHash.Map.t array; + mutable pool_len: int; + mutable recycle_count: int; + mutable miss_count: int; +} + +let create ~capacity:pool_capacity = + { + outer = ReactiveHash.Map.create (); + pool = Array.make pool_capacity (Obj.magic 0); + pool_len = 0; + recycle_count = 0; + miss_count = 0; + } + +let grow_pool t = + let old_pool = t.pool in + let old_cap = Array.length old_pool in + let new_cap = max 1 (2 * old_cap) in + let new_pool = Array.make new_cap (Obj.magic 0) in + Array.blit old_pool 0 new_pool 0 old_cap; + t.pool <- new_pool; + ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_map_resize + +let pool_push t inner = + if t.pool_len >= Array.length t.pool then grow_pool t; + Array.unsafe_set t.pool t.pool_len inner; + t.pool_len <- t.pool_len + 1 + +let pool_pop t = + if t.pool_len > 0 then ( + t.pool_len <- t.pool_len - 1; + let inner = Array.unsafe_get t.pool t.pool_len in + Array.unsafe_set t.pool t.pool_len (Obj.magic 0); + inner) + else ( + t.miss_count <- t.miss_count + 1; + ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_map_miss_create; + ReactiveHash.Map.create ()) + +let ensure_inner t ko = + let m = ReactiveHash.Map.find_maybe t.outer ko in + if ReactiveMaybe.is_some m then ReactiveMaybe.unsafe_get m + else + let inner = pool_pop t in + ReactiveHash.Map.replace t.outer ko inner; + inner + +let replace t ko ki v = + let inner = ensure_inner t ko in + ReactiveHash.Map.replace inner ki v + +let remove_from_inner_and_recycle_if_empty t ko ki = + let mb = ReactiveHash.Map.find_maybe t.outer ko in + if ReactiveMaybe.is_some mb then ( + let inner = ReactiveMaybe.unsafe_get mb in + ReactiveHash.Map.remove inner ki; + let after = ReactiveHash.Map.cardinal inner in + if after = 0 then ( + ReactiveHash.Map.remove t.outer ko; + ReactiveHash.Map.clear inner; + pool_push t inner; + t.recycle_count <- t.recycle_count + 1); + ReactiveAllocTrace.emit_op_kind + ReactiveAllocTrace.Pool_map_remove_recycle_if_empty) + +let drain_outer t ko ctx f = + let mb = ReactiveHash.Map.find_maybe t.outer ko in + if ReactiveMaybe.is_some mb then ( + let inner = ReactiveMaybe.unsafe_get mb in + ReactiveHash.Map.iter_with f ctx inner; + ReactiveHash.Map.remove t.outer ko; + ReactiveHash.Map.clear inner; + pool_push t inner; + t.recycle_count <- t.recycle_count + 1; + ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_map_drain_outer) + +let find_inner_maybe t ko = ReactiveHash.Map.find_maybe t.outer ko + +let iter_inner_with t ko ctx f = + let mb = ReactiveHash.Map.find_maybe t.outer ko in + if ReactiveMaybe.is_some mb then + ReactiveHash.Map.iter_with f ctx (ReactiveMaybe.unsafe_get mb) + +let inner_cardinal t ko = + let mb = ReactiveHash.Map.find_maybe t.outer ko in + if ReactiveMaybe.is_some mb then + ReactiveHash.Map.cardinal (ReactiveMaybe.unsafe_get mb) + else 0 + +let outer_cardinal t = ReactiveHash.Map.cardinal t.outer + +let tighten t = ReactiveHash.Map.tighten t.outer + +let debug_miss_count t = t.miss_count diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/ReactivePoolMapMap.mli new file mode 100644 index 00000000000..f307f1349d7 --- /dev/null +++ b/analysis/reactive/src/ReactivePoolMapMap.mli @@ -0,0 +1,42 @@ +(** A map from outer keys to inner maps, with pooled recycling of inner maps. + + Designed for churn-heavy map-of-map usage where empty inner maps should be + removed and recycled deterministically. *) + +type ('ko, 'ki, 'v) t + +val create : capacity:int -> ('ko, 'ki, 'v) t +(** [create ~capacity] creates an empty pooled map-of-map. + [capacity] is the initial pool capacity; pool grows on demand. *) + +val replace : ('ko, 'ki, 'v) t -> 'ko -> 'ki -> 'v -> 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 -> 'ki -> unit +(** Removes [ki] from [ko]'s inner map. If it becomes empty, removes [ko], + clears and recycles the inner map. No-op if [ko] is absent. *) + +val drain_outer : + ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit +(** [drain_outer t ko ctx f] iterates [f ctx ki v] for all entries in [ko]'s + inner map, then removes [ko], clears and recycles the inner map. + No-op if [ko] is absent. *) + +val find_inner_maybe : + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t ReactiveMaybe.t +(** Zero-allocation lookup of inner map by outer key. *) + +val iter_inner_with : + ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> 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 -> int +val outer_cardinal : ('ko, 'ki, 'v) t -> int + +val tighten : ('ko, 'ki, 'v) t -> unit +(** Shrinks the outer map capacity after major churn. *) + +val debug_miss_count : ('ko, 'ki, 'v) t -> int +(** Number of pool misses (fresh inner-map allocations) since creation. *) diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml new file mode 100644 index 00000000000..d158b166a2f --- /dev/null +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -0,0 +1,107 @@ +(** A map from keys to sets, with an internal pool for recycling inner sets. + + When a key is removed via [drain_key] or + [remove_from_set_and_recycle_if_empty], its inner set is cleared and returned + to a pool. When a new key is added via [add], a set is taken from the + pool (if available) instead of allocating a fresh one. + + This eliminates allocation under key churn (e.g., position keys that shift + on every source edit). *) + +type ('k, 'v) t = { + outer: ('k, 'v ReactiveHash.Set.t) ReactiveHash.Map.t; + mutable pool: 'v ReactiveHash.Set.t array; + mutable pool_len: int; + mutable recycle_count: int; + mutable miss_count: int; +} + +let create ~capacity:pool_capacity = + { + outer = ReactiveHash.Map.create (); + pool = Array.make pool_capacity (Obj.magic 0); + pool_len = 0; + recycle_count = 0; + miss_count = 0; + } + +let grow_pool t = + let old_pool = t.pool in + let old_cap = Array.length old_pool in + let new_cap = max 1 (2 * old_cap) in + let new_pool = Array.make new_cap (Obj.magic 0) in + Array.blit old_pool 0 new_pool 0 old_cap; + t.pool <- new_pool; + ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_set_resize + +let pool_push t set = + if t.pool_len >= Array.length t.pool then grow_pool t; + Array.unsafe_set t.pool t.pool_len set; + t.pool_len <- t.pool_len + 1 + +let pool_pop t = + if t.pool_len > 0 then ( + t.pool_len <- t.pool_len - 1; + let set = Array.unsafe_get t.pool t.pool_len in + Array.unsafe_set t.pool t.pool_len (Obj.magic 0); + set) + else ( + t.miss_count <- t.miss_count + 1; + ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_set_miss_create; + ReactiveHash.Set.create ()) + +let ensure t k = + let m = ReactiveHash.Map.find_maybe t.outer k in + if ReactiveMaybe.is_some m then ReactiveMaybe.unsafe_get m + else + let set = pool_pop t in + ReactiveHash.Map.replace t.outer k set; + set + +let add t k v = + let set = ensure t k in + ReactiveHash.Set.add set v + +let drain_key t k ctx f = + let mb = ReactiveHash.Map.find_maybe t.outer k in + if ReactiveMaybe.is_some mb then ( + let set = ReactiveMaybe.unsafe_get mb in + ReactiveHash.Set.iter_with f ctx set; + ReactiveHash.Map.remove t.outer k; + ReactiveHash.Set.clear set; + pool_push t set; + t.recycle_count <- t.recycle_count + 1; + ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_set_drain_key) + +let remove_from_set_and_recycle_if_empty t k v = + let mb = ReactiveHash.Map.find_maybe t.outer k in + if ReactiveMaybe.is_some mb then ( + let set = ReactiveMaybe.unsafe_get mb in + ReactiveHash.Set.remove set v; + let after = ReactiveHash.Set.cardinal set in + if after = 0 then ( + ReactiveHash.Map.remove t.outer k; + ReactiveHash.Set.clear set; + pool_push t set; + t.recycle_count <- t.recycle_count + 1); + ReactiveAllocTrace.emit_op_kind + ReactiveAllocTrace.Pool_set_remove_recycle_if_empty) + +let find_maybe t k = ReactiveHash.Map.find_maybe t.outer k + +let iter_with t ctx f = ReactiveHash.Map.iter_with f ctx t.outer + +let recycle_inner_set t _k set = + ReactiveHash.Set.clear set; + pool_push t set; + t.recycle_count <- t.recycle_count + 1 + +let clear t = + ReactiveHash.Map.iter_with recycle_inner_set t t.outer; + ReactiveHash.Map.clear t.outer + +let tighten t = ReactiveHash.Map.tighten t.outer + +let cardinal t = ReactiveHash.Map.cardinal t.outer + +let debug_miss_count t = t.miss_count diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli new file mode 100644 index 00000000000..a1309de69be --- /dev/null +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -0,0 +1,42 @@ +(** A map from keys to sets, with an internal pool for recycling inner sets. + + Eliminates allocation under key churn by recycling cleared inner sets. *) + +type ('k, 'v) t + +val create : capacity:int -> ('k, 'v) t +(** [create ~capacity] creates an empty pool map set. + [capacity] is the initial pool capacity; the pool grows on demand. *) + +val add : ('k, 'v) t -> 'k -> 'v -> unit +(** [add t k v] ensures a set exists for [k] and adds [v] to it. *) + +val drain_key : ('k, 'v) t -> 'k -> 'a -> ('a -> 'v -> 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 recycles its inner set. + No-op if [k] is absent. *) + +val remove_from_set_and_recycle_if_empty : ('k, 'v) t -> 'k -> 'v -> unit +(** [remove_from_set_and_recycle_if_empty t k v] removes [v] from [k]'s set. + If the set becomes empty, [k] is recycled. No-op if [k] is absent. *) + +val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveHash.Set.t ReactiveMaybe.t +(** Zero-allocation lookup. *) + +val iter_with : + ('k, 'v) t -> 'a -> ('a -> 'k -> 'v ReactiveHash.Set.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; inner sets are cleared and recycled. *) + +val tighten : ('k, 'v) t -> unit +(** [tighten t] shrinks the outer map's capacity after key churn. + Call explicitly after a batch of key removals. *) + +val cardinal : ('k, 'v) t -> int +(** Number of live entries in the outer map. *) + +val debug_miss_count : ('k, 'v) t -> int +(** Number of pool misses (fresh set allocations) since creation. + Intended for diagnostics and allocation tests. *) diff --git a/analysis/reactive/src/ReactiveQueue.ml b/analysis/reactive/src/ReactiveQueue.ml new file mode 100644 index 00000000000..e13f5f84fba --- /dev/null +++ b/analysis/reactive/src/ReactiveQueue.ml @@ -0,0 +1,36 @@ +(** Array-based FIFO queue. After [clear], subsequent [push] calls + reuse existing array slots — zero allocation until the array + needs to grow beyond its high-water mark. *) + +type 'a t = { + mutable data: Obj.t array; + mutable head: int; + mutable tail: int; (* next write position *) +} + +let create () = {data = [||]; head = 0; tail = 0} +let clear t = + t.head <- 0; + t.tail <- 0 +let is_empty t = t.head = t.tail + +let grow t = + let old_len = Array.length t.data in + let used = t.tail - t.head in + let new_len = max 16 (old_len * 2) in + let new_data = Array.make new_len (Obj.repr ()) in + Array.blit t.data t.head new_data 0 used; + t.data <- new_data; + t.head <- 0; + t.tail <- used + +let push t (x : 'a) = + if t.tail >= Array.length t.data then grow t; + Array.unsafe_set t.data t.tail (Obj.repr x); + t.tail <- t.tail + 1 + +let pop t = + if t.head = t.tail then invalid_arg "ReactiveQueue.pop: empty"; + let v = Array.unsafe_get t.data t.head in + t.head <- t.head + 1; + (Obj.obj v : 'a) diff --git a/analysis/reactive/src/ReactiveQueue.mli b/analysis/reactive/src/ReactiveQueue.mli new file mode 100644 index 00000000000..e54d325fe77 --- /dev/null +++ b/analysis/reactive/src/ReactiveQueue.mli @@ -0,0 +1,13 @@ +(** Array-based FIFO queue. After [clear], subsequent [push] calls + reuse existing array slots — zero allocation until the array + needs to grow beyond its high-water mark. *) + +type 'a t + +val create : unit -> 'a t +val clear : 'a t -> unit +val push : 'a t -> 'a -> unit +val is_empty : 'a t -> bool + +val pop : 'a t -> 'a +(** @raise Invalid_argument if the queue is empty. *) diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml new file mode 100644 index 00000000000..90ba77bf4e1 --- /dev/null +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -0,0 +1,141 @@ +(** Zero-allocation union state and processing logic. + + Uses ReactiveHash (Hachis-backed) tables for all internal state. + After steady-state capacity is reached, [process] performs zero + heap allocation. *) + +type ('k, 'v) t = { + merge: 'v -> 'v -> 'v; + left_values: ('k, 'v) ReactiveHash.Map.t; + right_values: ('k, 'v) ReactiveHash.Map.t; + target: ('k, 'v) ReactiveHash.Map.t; + left_scratch: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; + right_scratch: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; + affected: 'k ReactiveHash.Set.t; + output_wave: ('k, 'v ReactiveMaybe.t) ReactiveWave.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 ~output_wave = + { + merge; + left_values = ReactiveHash.Map.create (); + right_values = ReactiveHash.Map.create (); + target = ReactiveHash.Map.create (); + left_scratch = ReactiveHash.Map.create (); + right_scratch = ReactiveHash.Map.create (); + affected = ReactiveHash.Set.create (); + output_wave; + result = + { + entries_received = 0; + adds_received = 0; + removes_received = 0; + entries_emitted = 0; + adds_emitted = 0; + removes_emitted = 0; + }; + } + +let push_left t k mv = ReactiveHash.Map.replace t.left_scratch k mv +let push_right t k mv = ReactiveHash.Map.replace t.right_scratch k mv + +(* Module-level helpers for iter_with — avoid closure allocation *) + +let apply_left_entry t k (mv : 'v ReactiveMaybe.t) = + let r = t.result in + r.entries_received <- r.entries_received + 1; + if ReactiveMaybe.is_some mv then ( + ReactiveHash.Map.replace t.left_values k (ReactiveMaybe.unsafe_get mv); + r.adds_received <- r.adds_received + 1) + else ( + ReactiveHash.Map.remove t.left_values k; + r.removes_received <- r.removes_received + 1); + ReactiveHash.Set.add t.affected k + +let apply_right_entry t k (mv : 'v ReactiveMaybe.t) = + let r = t.result in + r.entries_received <- r.entries_received + 1; + if ReactiveMaybe.is_some mv then ( + ReactiveHash.Map.replace t.right_values k (ReactiveMaybe.unsafe_get mv); + r.adds_received <- r.adds_received + 1) + else ( + ReactiveHash.Map.remove t.right_values k; + r.removes_received <- r.removes_received + 1); + ReactiveHash.Set.add t.affected k + +let recompute_affected_entry t k = + let r = t.result in + let lv = ReactiveHash.Map.find_maybe t.left_values k in + let rv = ReactiveHash.Map.find_maybe t.right_values k in + let has_left = ReactiveMaybe.is_some lv in + let has_right = ReactiveMaybe.is_some rv in + if has_left then ( + if has_right then ( + let merged = + t.merge (ReactiveMaybe.unsafe_get lv) (ReactiveMaybe.unsafe_get rv) + in + ReactiveHash.Map.replace t.target k merged; + ReactiveWave.push t.output_wave k (ReactiveMaybe.some merged)) + else + let v = ReactiveMaybe.unsafe_get lv in + ReactiveHash.Map.replace t.target k v; + ReactiveWave.push t.output_wave k (ReactiveMaybe.some v)) + else if has_right then ( + let v = ReactiveMaybe.unsafe_get rv in + ReactiveHash.Map.replace t.target k v; + ReactiveWave.push t.output_wave k (ReactiveMaybe.some v)) + else ( + ReactiveHash.Map.remove t.target k; + ReactiveWave.push t.output_wave k ReactiveMaybe.none); + 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 = + ReactiveHash.Set.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; + + ReactiveHash.Map.iter_with apply_left_entry t t.left_scratch; + ReactiveHash.Map.iter_with apply_right_entry t t.right_scratch; + + ReactiveHash.Map.clear t.left_scratch; + ReactiveHash.Map.clear t.right_scratch; + + if ReactiveHash.Set.cardinal t.affected > 0 then ( + ReactiveWave.clear t.output_wave; + ReactiveHash.Set.iter_with recompute_affected_entry t t.affected); + + r + +let init_left t k v = + ReactiveHash.Map.replace t.left_values k v; + ReactiveHash.Map.replace t.target k v + +let init_right t k v = + ReactiveHash.Map.replace t.right_values k v; + let lv = ReactiveHash.Map.find_maybe t.left_values k in + let merged = + if ReactiveMaybe.is_some lv then t.merge (ReactiveMaybe.unsafe_get lv) v + else v + in + ReactiveHash.Map.replace t.target k merged + +let iter_target f t = ReactiveHash.Map.iter f t.target +let find_target t k = ReactiveHash.Map.find_maybe t.target k +let target_length t = ReactiveHash.Map.cardinal t.target diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli new file mode 100644 index 00000000000..ecf5824a996 --- /dev/null +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -0,0 +1,41 @@ +(** Zero-allocation union state and processing logic. + + This is a private module used by {!Reactive.union}. *) + +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 -> 'v -> 'v) -> + output_wave:('k, 'v ReactiveMaybe.t) ReactiveWave.t -> + ('k, 'v) t +(** Create union state with the given merge function and output wave buffer. *) + +val push_left : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t -> unit +(** Push an entry into the left scratch table. *) + +val push_right : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.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 -> 'v -> unit +(** Initialize a left entry (during setup, before subscriptions). *) + +val init_right : ('k, 'v) t -> 'k -> 'v -> unit +(** Initialize a right entry (during setup, after left). *) + +val iter_target : ('k -> 'v -> unit) -> ('k, 'v) t -> unit +val find_target : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t +val target_length : ('k, 'v) t -> int diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml new file mode 100644 index 00000000000..fb1dc32eb3a --- /dev/null +++ b/analysis/reactive/src/ReactiveWave.ml @@ -0,0 +1,31 @@ +type ('k, 'v) t = {keys: Obj.t array; vals: Obj.t array; mutable len: int} + +let create ~max_entries = + if max_entries <= 0 then + invalid_arg "ReactiveWave.create: max_entries must be > 0"; + { + keys = Array.make max_entries (Obj.repr ()); + vals = Array.make max_entries (Obj.repr ()); + len = 0; + } + +let clear t = t.len <- 0 + +let push (type k v) (t : (k, v) t) (k : k) (v : v) = + if t.len >= Array.length t.keys then + invalid_arg "ReactiveWave.push: capacity exceeded"; + t.keys.(t.len) <- Obj.repr k; + t.vals.(t.len) <- Obj.repr v; + t.len <- t.len + 1 + +let iter (type k v) (t : (k, v) t) (f : k -> v -> unit) = + for i = 0 to t.len - 1 do + f (Obj.obj t.keys.(i) : k) (Obj.obj t.vals.(i) : v) + done + +let iter_with (type a k v) (t : (k, v) t) (f : a -> k -> v -> unit) (arg : a) = + for i = 0 to t.len - 1 do + f arg (Obj.obj t.keys.(i) : k) (Obj.obj t.vals.(i) : v) + done + +let count t = t.len diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli new file mode 100644 index 00000000000..25f32dbd93f --- /dev/null +++ b/analysis/reactive/src/ReactiveWave.mli @@ -0,0 +1,13 @@ +type ('k, 'v) t + +val create : max_entries:int -> ('k, 'v) t +val clear : ('k, 'v) t -> unit +val push : ('k, 'v) t -> 'k -> 'v -> unit +val iter : ('k, 'v) t -> ('k -> 'v -> unit) -> unit + +val iter_with : ('k, 'v) t -> ('a -> 'k -> 'v -> 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 cc8d382ccd8..6c699f4cce4 100644 --- a/analysis/reactive/src/dune +++ b/analysis/reactive/src/dune @@ -1,5 +1,5 @@ (library (name reactive) (wrapped false) - (private_modules ReactiveFixpoint) + (private_modules ReactiveQueue) (libraries unix)) diff --git a/analysis/reactive/test/AllocMeasure.ml b/analysis/reactive/test/AllocMeasure.ml new file mode 100644 index 00000000000..f37393ea6a9 --- /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 00000000000..bd5686e78c2 --- /dev/null +++ b/analysis/reactive/test/AllocTest.ml @@ -0,0 +1,642 @@ +(** 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 words_since = AllocMeasure.words_since + +(* ---- Fixpoint allocation ---- *) + +let test_fixpoint_alloc_n n = + let state = + ReactiveFixpoint.create ~max_nodes:(n * 10) ~max_edges:(n * 100) + in + + (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) + let root_snap = ReactiveWave.create ~max_entries:1 in + let edge_snap = ReactiveWave.create ~max_entries:n in + ReactiveWave.push root_snap 0 (); + for i = 0 to n - 2 do + ReactiveWave.push edge_snap i [i + 1] + done; + ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; + assert (ReactiveFixpoint.current_length state = n); + + (* Pre-build waves once *) + let remove_root = ReactiveWave.create ~max_entries:1 in + ReactiveWave.push remove_root 0 ReactiveMaybe.none; + let add_root = ReactiveWave.create ~max_entries:1 in + ReactiveWave.push add_root 0 (ReactiveMaybe.some ()); + let no_edges = ReactiveWave.create ~max_entries:1 in + + (* Warmup *) + for _ = 1 to 5 do + ignore + (ReactiveFixpoint.apply_wave state ~roots:remove_root ~edges:no_edges); + ignore (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 + ignore + (ReactiveFixpoint.apply_wave state ~roots:remove_root ~edges:no_edges); + ignore (ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges) + done; + assert (ReactiveFixpoint.current_length state = n); + words_since () / iters + +let test_fixpoint_alloc () = + 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) + [10; 100; 1000]; + Printf.printf "PASSED\n\n" + +(* ---- FlatMap allocation ---- *) + +let test_flatmap_alloc_n n = + let output_wave = ReactiveWave.create ~max_entries:(n * 2) in + let state = + ReactiveFlatMap.create + ~f:(fun k v emit -> emit k v) + ~merge:(fun _l r -> r) + ~output_wave + in + + (* Populate: n entries *) + for i = 0 to n - 1 do + ReactiveFlatMap.push state i (ReactiveMaybe.some 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 i ReactiveMaybe.none + done; + ignore (ReactiveFlatMap.process state); + assert (ReactiveFlatMap.target_length state = 0); + for i = 0 to n - 1 do + ReactiveFlatMap.push state i (ReactiveMaybe.some 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 i ReactiveMaybe.none + done; + ignore (ReactiveFlatMap.process state); + for i = 0 to n - 1 do + ReactiveFlatMap.push state i (ReactiveMaybe.some i) + done; + ignore (ReactiveFlatMap.process state) + done; + assert (ReactiveFlatMap.target_length state = n); + words_since () / iters + +let test_flatmap_alloc () = + 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) + [10; 100; 1000]; + Printf.printf "PASSED\n\n" + +(* ---- Union allocation ---- *) + +let test_union_alloc_n n = + let output_wave = ReactiveWave.create ~max_entries:(n * 2) in + let state = ReactiveUnion.create ~merge:(fun _l r -> r) ~output_wave in + + (* Populate: n entries on the left side *) + for i = 0 to n - 1 do + ReactiveUnion.push_left state i (ReactiveMaybe.some 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 i ReactiveMaybe.none + done; + ignore (ReactiveUnion.process state); + assert (ReactiveUnion.target_length state = 0); + for i = 0 to n - 1 do + ReactiveUnion.push_left state i (ReactiveMaybe.some 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 i ReactiveMaybe.none + done; + ignore (ReactiveUnion.process state); + for i = 0 to n - 1 do + ReactiveUnion.push_left state i (ReactiveMaybe.some i) + done; + ignore (ReactiveUnion.process state) + done; + assert (ReactiveUnion.target_length state = n); + words_since () / iters + +let test_union_alloc () = + 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) + [10; 100; 1000]; + Printf.printf "PASSED\n\n" + +(* ---- Join allocation ---- *) + +let test_join_alloc_n n = + let output_wave = ReactiveWave.create ~max_entries:(n * 2) in + let right_tbl = ReactiveHash.Map.create () in + let state = + ReactiveJoin.create + ~key_of:(fun k _v -> k) + ~f:(fun k v right_mb emit -> + if ReactiveMaybe.is_some right_mb then + emit k (v + ReactiveMaybe.unsafe_get right_mb)) + ~merge:(fun _l r -> r) + ~right_get:(ReactiveHash.Map.find_maybe right_tbl) + ~output_wave + in + + (* Populate: n entries on the right, n on the left *) + for i = 0 to n - 1 do + ReactiveHash.Map.replace right_tbl i (i * 10) + done; + for i = 0 to n - 1 do + ReactiveJoin.push_left state i (ReactiveMaybe.some 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 i ReactiveMaybe.none + done; + ignore (ReactiveJoin.process state); + assert (ReactiveJoin.target_length state = 0); + for i = 0 to n - 1 do + ReactiveJoin.push_left state i (ReactiveMaybe.some 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 i ReactiveMaybe.none + done; + ignore (ReactiveJoin.process state); + for i = 0 to n - 1 do + ReactiveJoin.push_left state i (ReactiveMaybe.some i) + done; + ignore (ReactiveJoin.process state) + done; + assert (ReactiveJoin.target_length state = n); + words_since () / iters + +let test_join_alloc () = + 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) + [10; 100; 1000]; + 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 ~name:"left" () in + let right, emit_right = Reactive.source ~name:"right" () in + + (* Join: for each (k, v) in left, look up k in right, produce (k, v + right_v) *) + let joined = + Reactive.join ~name:"joined" left right + ~key_of:(fun k _v -> k) + ~f:(fun k v right_mb emit -> + if ReactiveMaybe.is_some right_mb then + emit k (v + ReactiveMaybe.unsafe_get right_mb)) + () + 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 = ReactiveWave.create ~max_entries:n in + for i = 0 to n - 1 do + ReactiveWave.push remove_wave i ReactiveMaybe.none + done; + let add_wave = ReactiveWave.create ~max_entries:n in + for i = 0 to n - 1 do + ReactiveWave.push add_wave i (ReactiveMaybe.some 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); + words_since () / iters + +let test_reactive_join_alloc () = + 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) + [10; 100; 1000]; + Printf.printf "PASSED\n\n" + +(* ---- Reactive.fixpoint end-to-end allocation ---- *) + +let test_reactive_fixpoint_alloc_n n = + Reactive.reset (); + let init, emit_root = Reactive.source ~name:"init" () in + let edges, emit_edges = Reactive.source ~name:"edges" () in + + (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) + for i = 0 to n - 2 do + emit_set emit_edges i [i + 1] + done; + let reachable = Reactive.fixpoint ~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 = ReactiveWave.create ~max_entries:1 in + ReactiveWave.push remove_wave 0 ReactiveMaybe.none; + let add_wave = ReactiveWave.create ~max_entries:1 in + ReactiveWave.push add_wave 0 (ReactiveMaybe.some ()); + + (* 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); + words_since () / iters + +let test_reactive_fixpoint_alloc () = + 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) + [10; 100; 1000]; + 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 ~name:"left" () in + let right, emit_right = Reactive.source ~name:"right" () in + + let merged = Reactive.union ~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 = ReactiveWave.create ~max_entries:n in + for i = 0 to n - 1 do + ReactiveWave.push remove_wave i ReactiveMaybe.none + done; + let add_wave = ReactiveWave.create ~max_entries:n in + for i = 0 to n - 1 do + ReactiveWave.push add_wave i (ReactiveMaybe.some 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); + words_since () / iters + +let test_reactive_union_alloc () = + 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) + [10; 100; 1000]; + 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 ~name:"src" () in + + let derived = + Reactive.flatMap ~name:"derived" src ~f:(fun k v emit -> emit 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 = ReactiveWave.create ~max_entries:n in + for i = 0 to n - 1 do + ReactiveWave.push remove_wave i ReactiveMaybe.none + done; + let add_wave = ReactiveWave.create ~max_entries:n in + for i = 0 to n - 1 do + ReactiveWave.push add_wave i (ReactiveMaybe.some 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); + words_since () / iters + +let test_reactive_flatmap_alloc () = + 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) + [10; 100; 1000]; + Printf.printf "PASSED\n\n" + +(* ---- PoolMapSet allocation ---- *) + +type empty_set_stats = {mutable total: int; mutable empty: int} + +let count_pool_empty_sets pms = + let s = {total = 0; empty = 0} in + ReactivePoolMapSet.iter_with pms s (fun st _k set -> + st.total <- st.total + 1; + if ReactiveHash.Set.cardinal set = 0 then st.empty <- st.empty + 1); + s + +let test_pool_map_set_pattern_drain_key_churn () = + Printf.printf "=== Test: PoolMapSet pattern (drain_key churn) ===\n"; + let n = 100 in + let iters = 100 in + let pms = ReactivePoolMapSet.create ~capacity:(n * 2) in + + for i = 0 to n - 1 do + ReactivePoolMapSet.add pms i i + done; + + let miss_before = ReactivePoolMapSet.debug_miss_count pms in + ignore (words_since ()); + for iter = 1 to iters do + let base = iter * n in + for i = 0 to n - 1 do + ReactivePoolMapSet.drain_key pms (base - n + i) () (fun () _ -> ()) + done; + for i = 0 to n - 1 do + ReactivePoolMapSet.add pms (base + i) i + done + done; + let words = words_since () / iters in + let miss_after = ReactivePoolMapSet.debug_miss_count pms in + let miss_delta = miss_after - miss_before in + let st = count_pool_empty_sets pms in + Printf.printf + " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_sets=%d/%d\n" words + miss_delta + (ReactivePoolMapSet.cardinal pms) + st.empty st.total; + assert (ReactivePoolMapSet.cardinal pms = n); + assert (st.empty = 0); + assert (miss_delta = 0); + Printf.printf "PASSED\n\n" + +let test_pool_map_set_pattern_remove_recycle_churn () = + Printf.printf + "=== Test: PoolMapSet pattern (remove_from_set_and_recycle_if_empty churn) \ + ===\n"; + let n = 100 in + let iters = 100 in + let pms = ReactivePoolMapSet.create ~capacity:(n * 2) in + + for i = 0 to n - 1 do + ReactivePoolMapSet.add pms i i + done; + + let miss_before = ReactivePoolMapSet.debug_miss_count pms in + ignore (words_since ()); + for iter = 1 to iters do + let base = iter * n in + for i = 0 to n - 1 do + ReactivePoolMapSet.remove_from_set_and_recycle_if_empty pms + (base - n + i) + i + done; + for i = 0 to n - 1 do + ReactivePoolMapSet.add pms (base + i) i + done + done; + let words = words_since () / iters in + let miss_after = ReactivePoolMapSet.debug_miss_count pms in + let miss_delta = miss_after - miss_before in + let st = count_pool_empty_sets pms in + Printf.printf + " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_sets=%d/%d\n" words + miss_delta + (ReactivePoolMapSet.cardinal pms) + st.empty st.total; + assert (ReactivePoolMapSet.cardinal pms = n); + assert (st.empty = 0); + assert (miss_delta = 0); + Printf.printf "PASSED\n\n" + +(* ---- PoolMapMap allocation ---- *) + +type inner_map_stats = {mutable empty: int} + +let count_empty_inner_maps pmm ~start ~count = + let s = {empty = 0} in + for i = 0 to count - 1 do + if ReactivePoolMapMap.inner_cardinal pmm (start + i) = 0 then + s.empty <- s.empty + 1 + done; + s + +let test_pool_map_map_pattern_drain_outer_churn () = + Printf.printf "=== Test: PoolMapMap pattern (drain_outer churn) ===\n"; + let n = 100 in + let iters = 100 in + let pmm = ReactivePoolMapMap.create ~capacity:(n * 2) in + + for i = 0 to n - 1 do + ReactivePoolMapMap.replace pmm i i i + done; + + let miss_before = ReactivePoolMapMap.debug_miss_count pmm in + ignore (words_since ()); + for iter = 1 to iters do + let base = iter * n in + for i = 0 to n - 1 do + ReactivePoolMapMap.drain_outer pmm (base - n + i) () (fun () _ _ -> ()) + done; + for i = 0 to n - 1 do + ReactivePoolMapMap.replace pmm (base + i) i i + done + done; + let words = words_since () / iters in + let miss_after = ReactivePoolMapMap.debug_miss_count pmm in + let miss_delta = miss_after - miss_before in + let final_start = iters * n in + let st = count_empty_inner_maps pmm ~start:final_start ~count:n in + Printf.printf + " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_inners=%d/%d\n" words + miss_delta + (ReactivePoolMapMap.outer_cardinal pmm) + st.empty n; + assert (ReactivePoolMapMap.outer_cardinal pmm = n); + assert (st.empty = 0); + assert (miss_delta = 0); + Printf.printf "PASSED\n\n" + +let test_pool_map_map_pattern_remove_recycle_churn () = + Printf.printf + "=== Test: PoolMapMap pattern (remove_from_inner_and_recycle_if_empty \ + churn) ===\n"; + let n = 100 in + let iters = 100 in + let pmm = ReactivePoolMapMap.create ~capacity:(n * 2) in + + for i = 0 to n - 1 do + ReactivePoolMapMap.replace pmm i i i + done; + + let miss_before = ReactivePoolMapMap.debug_miss_count pmm in + ignore (words_since ()); + for iter = 1 to iters do + let base = iter * n in + for i = 0 to n - 1 do + ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty pmm + (base - n + i) + i + done; + for i = 0 to n - 1 do + ReactivePoolMapMap.replace pmm (base + i) i i + done + done; + let words = words_since () / iters in + let miss_after = ReactivePoolMapMap.debug_miss_count pmm in + let miss_delta = miss_after - miss_before in + let final_start = iters * n in + let st = count_empty_inner_maps pmm ~start:final_start ~count:n in + Printf.printf + " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_inners=%d/%d\n" words + miss_delta + (ReactivePoolMapMap.outer_cardinal pmm) + st.empty n; + assert (ReactivePoolMapMap.outer_cardinal pmm = n); + assert (st.empty = 0); + assert (miss_delta = 0); + Printf.printf "PASSED\n\n" + +let run_all () = + Printf.printf "\n====== Allocation Tests ======\n\n"; + test_fixpoint_alloc (); + test_union_alloc (); + test_flatmap_alloc (); + test_join_alloc (); + test_reactive_fixpoint_alloc (); + test_reactive_union_alloc (); + test_reactive_flatmap_alloc (); + test_reactive_join_alloc (); + test_pool_map_set_pattern_drain_key_churn (); + test_pool_map_set_pattern_remove_recycle_churn (); + test_pool_map_map_pattern_drain_outer_churn (); + test_pool_map_map_pattern_remove_recycle_churn () diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 4c750d16cff..5675ea87bb2 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -9,7 +9,9 @@ let test_batch_flatmap () = let source, emit = source ~name:"source" () in let derived = - flatMap ~name:"derived" source ~f:(fun k v -> [(k ^ "_derived", v * 2)]) () + flatMap ~name:"derived" source + ~f:(fun k v emit -> emit (k ^ "_derived") (v * 2)) + () in (* Subscribe to track what comes out *) @@ -17,23 +19,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" @@ -51,33 +51,29 @@ let test_batch_fixpoint () = 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 ReactiveMaybe.is_some mv then incr total_added)) fp; (* Set up edges first *) - emit_edges (Set ("a", ["b"; "c"])); - emit_edges (Set ("b", ["d"])); + emit_set emit_edges "a" ["b"; "c"]; + emit_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 b978ea94685..be4011738a6 100644 --- a/analysis/reactive/test/FixpointBasicTest.ml +++ b/analysis/reactive/test/FixpointBasicTest.ml @@ -1,6 +1,7 @@ (** Basic fixpoint graph traversal tests *) open Reactive +open TestHelpers let test_fixpoint () = reset (); @@ -10,9 +11,9 @@ let test_fixpoint () = let edges, emit_edges = source ~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_set emit_edges 1 [2; 3]; + emit_set emit_edges 2 [4]; + emit_set emit_edges 3 [4]; (* Compute fixpoint *) let reachable = fixpoint ~name:"reachable" ~init ~edges () in @@ -22,32 +23,32 @@ let test_fixpoint () = 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_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" @@ -59,18 +60,18 @@ let test_fixpoint_basic_expansion () = let edges, emit_edges = source ~name:"edges" () in (* Graph: a -> b -> c *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); + emit_set emit_edges "a" ["b"]; + emit_set emit_edges "b" ["c"]; let fp = fixpoint ~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" @@ -82,19 +83,19 @@ let test_fixpoint_multiple_roots () = let edges, emit_edges = source ~name:"edges" () in (* Graph: a -> b, c -> d (disconnected components) *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("c", ["d"])); + emit_set emit_edges "a" ["b"]; + emit_set emit_edges "c" ["d"]; let fp = fixpoint ~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" @@ -106,13 +107,13 @@ let test_fixpoint_diamond () = let edges, emit_edges = source ~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_set emit_edges "a" ["b"; "c"]; + emit_set emit_edges "b" ["d"]; + emit_set emit_edges "c" ["d"]; let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("a", ())); + emit_set emit_init "a" (); assert (length fp = 4); @@ -126,18 +127,18 @@ let test_fixpoint_cycle () = let edges, emit_edges = source ~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_set emit_edges "a" ["b"]; + emit_set emit_edges "b" ["c"]; + emit_set emit_edges "c" ["b"]; let fp = fixpoint ~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" @@ -148,7 +149,7 @@ let test_fixpoint_empty_base () = let init, _emit_init = source ~name:"init" () in let edges, emit_edges = source ~name:"edges" () in - emit_edges (Set ("a", ["b"])); + emit_set emit_edges "a" ["b"]; let fp = fixpoint ~name:"fp" ~init ~edges () in @@ -164,14 +165,14 @@ let test_fixpoint_self_loop () = let edges, emit_edges = source ~name:"edges" () in (* Graph: a -> a (self loop) *) - emit_edges (Set ("a", ["a"])); + emit_set emit_edges "a" ["a"]; let fp = fixpoint ~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" @@ -181,11 +182,11 @@ let test_fixpoint_existing_data () = (* Create source and pre-populate *) let init, emit_init = source ~name:"init" () in - emit_init (Set ("root", ())); + emit_set emit_init "root" (); let edges, emit_edges = source ~name:"edges" () in - emit_edges (Set ("root", ["a"; "b"])); - emit_edges (Set ("a", ["c"])); + emit_set emit_edges "root" ["a"; "b"]; + emit_set emit_edges "a" ["c"]; (* Create fixpoint - should immediately have all reachable *) let fp = fixpoint ~name:"fp" ~init ~edges () in @@ -193,10 +194,10 @@ let test_fixpoint_existing_data () = 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 e0c2d0b6cbe..428393533eb 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -11,12 +11,12 @@ let test_fixpoint_add_base () = let edges, emit_edges = source ~name:"edges" () in (* Graph: a -> b, c -> d *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("c", ["d"])); + emit_set emit_edges "a" ["b"]; + emit_set emit_edges "c" ["d"]; let fp = fixpoint ~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 ReactiveMaybe.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); @@ -56,26 +53,25 @@ let test_fixpoint_remove_base () = let edges, emit_edges = source ~name:"edges" () in (* Graph: a -> b -> c *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); + emit_set emit_edges "a" ["b"]; + emit_set emit_edges "b" ["c"]; let fp = fixpoint ~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 (ReactiveMaybe.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); @@ -92,23 +88,21 @@ let test_fixpoint_add_edge () = let fp = fixpoint ~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 ReactiveMaybe.is_some mv then added := k :: !added) + entries) fp; (* Add edge a -> b *) - emit_edges (Set ("a", ["b"])); + emit_set emit_edges "a" ["b"]; Printf.printf "Added: [%s]\n" (String.concat ", " !added); assert (List.mem "b" !added); @@ -124,27 +118,26 @@ let test_fixpoint_remove_edge () = let edges, emit_edges = source ~name:"edges" () in (* Graph: a -> b -> c *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("b", ["c"])); + emit_set emit_edges "a" ["b"]; + emit_set emit_edges "b" ["c"]; let fp = fixpoint ~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 (ReactiveMaybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove edge a -> b *) - emit_edges (Set ("a", [])); + (* remove edge a -> b *) + emit_set emit_edges "a" []; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (List.length !removed = 2); @@ -162,28 +155,27 @@ let test_fixpoint_cycle_removal () = let edges, emit_edges = source ~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_set emit_edges "a" ["b"]; + emit_set emit_edges "b" ["c"]; + emit_set emit_edges "c" ["b"]; let fp = fixpoint ~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 (ReactiveMaybe.is_some mv) then removed := k :: !removed) + entries) fp; - (* Remove edge a -> b *) - emit_edges (Set ("a", [])); + (* remove edge a -> b *) + emit_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 *) @@ -204,27 +196,26 @@ let test_fixpoint_alternative_support () = (* 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_set emit_edges "a" ["b"; "c"]; + emit_set emit_edges "c" ["b"]; let fp = fixpoint ~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 (ReactiveMaybe.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_set emit_edges "a" ["c"]; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); (* b should NOT be removed - still reachable via c *) @@ -240,8 +231,8 @@ let test_fixpoint_deltas () = let init, emit_init = source ~name:"init" () in let edges, emit_edges = source ~name:"edges" () in - emit_edges (Set (1, [2; 3])); - emit_edges (Set (2, [4])); + emit_set emit_edges 1 [2; 3]; + emit_set emit_edges 2 [4]; let fp = fixpoint ~name:"fp" ~init ~edges () in @@ -249,13 +240,11 @@ let test_fixpoint_deltas () = 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,22 +252,22 @@ let test_fixpoint_deltas () = all_entries := []; (* Add edge 3 -> 5 *) - emit_edges (Set (3, [5])); + emit_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 @@ -294,41 +283,38 @@ let test_fixpoint_remove_spurious_root () = 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 ReactiveMaybe.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; 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; String.concat ", " (List.sort String.compare !items)); (* Step 3: Edge root -> a is added *) - emit_edges (Set ("root", ["a"])); + emit_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; 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_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; @@ -340,7 +326,7 @@ 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 @@ -350,7 +336,7 @@ let test_fixpoint_remove_spurious_root () = (* 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" @@ -364,8 +350,8 @@ let test_fixpoint_remove_edge_entry_alternative_source () = let edges, emit_edges = source ~name:"edges" () in (* Set up initial edges: a -> b, c -> b *) - emit_edges (Set ("a", ["b"])); - emit_edges (Set ("c", ["b"])); + emit_set emit_edges "a" ["b"]; + emit_set emit_edges "c" ["b"]; let fp = fixpoint ~name:"fp" ~init ~edges () in @@ -373,17 +359,16 @@ let test_fixpoint_remove_edge_entry_alternative_source () = 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 (ReactiveMaybe.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 @@ -394,10 +379,10 @@ let test_fixpoint_remove_edge_entry_alternative_source () = 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; String.concat ", " (List.sort String.compare !items)); @@ -405,7 +390,7 @@ let test_fixpoint_remove_edge_entry_alternative_source () = (* 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" @@ -424,23 +409,20 @@ let test_fixpoint_remove_edge_rederivation () = 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 ReactiveMaybe.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_set emit_edges "root" ["a"]; + emit_set emit_edges "a" ["b"; "c"]; + emit_set emit_edges "b" ["c"]; Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in @@ -452,8 +434,8 @@ 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_set emit_edges "a" ["b"]; Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in @@ -464,21 +446,21 @@ let test_fixpoint_remove_edge_rederivation () = (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 (* Set up edges before creating fixpoint *) - emit_edges (Set ("a", ["c"])); - emit_edges (Set ("b", ["c"])); + emit_set emit_edges "a" ["c"]; + emit_set emit_edges "b" ["c"]; let fp = fixpoint ~name:"fp" ~init ~edges () in @@ -486,17 +468,16 @@ let test_fixpoint_remove_edge_entry_rederivation () = 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 (ReactiveMaybe.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 @@ -507,10 +488,10 @@ let test_fixpoint_remove_edge_entry_rederivation () = 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; String.concat ", " (List.sort String.compare !items)); @@ -518,7 +499,7 @@ let test_fixpoint_remove_edge_entry_rederivation () = (* 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" @@ -537,23 +518,20 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = 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 ReactiveMaybe.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_set emit_edges "root" ["a"]; + emit_set emit_edges "a" ["b"; "c"]; + emit_set emit_edges "b" ["c"]; Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in @@ -561,13 +539,13 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = 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_set emit_edges "a" ["b"]; Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in @@ -578,7 +556,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = (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,90 +564,88 @@ 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 (* 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_set emit_edges "r" ["a"; "b"]; + emit_set emit_edges "a" ["y"]; + emit_set emit_edges "b" ["c"]; + emit_set emit_edges "c" ["x"]; + emit_set emit_edges "x" ["y"]; let fp = fixpoint ~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 (ReactiveMaybe.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 (* 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_set emit_edges "r1" ["a"]; + emit_set emit_edges "a" ["y"]; + emit_set emit_edges "r2" ["b"]; + emit_set emit_edges "b" ["c"]; + emit_set emit_edges "c" ["x"]; + emit_set emit_edges "x" ["y"]; let fp = fixpoint ~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 (ReactiveMaybe.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 () = @@ -680,37 +656,36 @@ let test_fixpoint_batch_overlapping_deletions () = let edges, emit_edges = source ~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_set emit_edges "r" ["a"; "b"]; + emit_set emit_edges "a" ["x"]; + emit_set emit_edges "b" ["x"]; + emit_set emit_edges "x" ["y"]; let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + 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 (ReactiveMaybe.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_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 *) @@ -724,39 +699,36 @@ let test_fixpoint_batch_delete_add_same_wave () = let edges, emit_edges = source ~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_set emit_edges "r" ["a"; "c"]; + emit_set emit_edges "a" ["x"]; + emit_set emit_edges "c" []; let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + 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 ReactiveMaybe.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_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 = []); @@ -771,33 +743,32 @@ let test_fixpoint_fanin_single_predecessor_removed () = let edges, emit_edges = source ~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_set emit_edges "r" ["a"; "b"; "c"]; + emit_set emit_edges "a" ["z"]; + emit_set emit_edges "b" ["z"]; + emit_set emit_edges "c" ["z"]; let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + 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 (ReactiveMaybe.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_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 = []); @@ -812,49 +783,48 @@ let test_fixpoint_cycle_alternative_external_support () = let edges, emit_edges = source ~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_set emit_edges "r1" ["b"]; + emit_set emit_edges "r2" ["c"]; + emit_set emit_edges "b" ["c"]; + emit_set emit_edges "c" ["b"]; let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r1", ())); - emit_init (Set ("r2", ())); + 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 (ReactiveMaybe.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_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_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" @@ -869,41 +839,38 @@ let test_fixpoint_remove_then_readd_via_expansion_same_wave () = (* 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_set emit_edges "r" ["s"]; + emit_set emit_edges "s" ["x"]; + emit_set emit_edges "y" ["x"]; let fp = fixpoint ~name:"fp" ~init ~edges () in - emit_init (Set ("r", ())); + 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 ReactiveMaybe.is_some mv then added := k :: !added + else removed := k :: !removed) entries) fp; - emit_edges (Set ("s", ["y"])); + emit_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 b9d20504699..c1e3175cc95 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/FlatMapTest.ml @@ -13,38 +13,40 @@ let test_flatmap_basic () = (* 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)]) + ~f:(fun key value emit -> + emit (key * 10) value; + emit ((key * 10) + 1) value; + emit ((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" @@ -57,27 +59,27 @@ let test_flatmap_with_merge () = (* Create derived with merge *) let derived = flatMap ~name:"derived" source - ~f:(fun _key values -> [(0, values)]) (* all contribute to key 0 *) + ~f:(fun _key values emit -> emit 0 values) (* all contribute to key 0 *) ~merge:IntSet.union () 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])); @@ -94,37 +96,37 @@ let test_composition () = (* 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) + ~f:(fun path items emit -> + List.iteri + (fun i item -> emit (Printf.sprintf "%s:%d" path i) item) + 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) + ~f:(fun key value emit -> + String.iteri (fun i c -> emit (Printf.sprintf "%s:%d" key i) c) 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); @@ -140,21 +142,21 @@ let test_flatmap_on_existing_data () = (* Create source and add data before creating flatMap *) let source, emit = source ~name:"source" () in - emit (Set (1, "a")); - emit (Set (2, "b")); + 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 ~name:"derived" source ~f:(fun k v emit -> emit (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 39540758775..cb0322626aa 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,19 @@ 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 + ReactiveWave.iter wave (fun k mv -> + 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 ReactiveMaybe.is_some mv then (a + 1, r) else (a, r + 1)) (0, 0) entries let sum_deltas deltas = @@ -45,36 +46,35 @@ let test_same_source_anti_join () = let src, emit = source ~name:"source" () in let refs = - flatMap ~name:"refs" src ~f:(fun _file (data : file_data) -> data.refs) () + flatMap ~name:"refs" src + ~f:(fun _file (data : file_data) emit -> + List.iter (fun (k, v) -> emit k v) data.refs) + () in let decls = flatMap ~name:"decls" src - ~f:(fun _file (data : file_data) -> - List.map (fun pos -> (pos, ())) data.decl_positions) + ~f:(fun _file (data : file_data) emit -> + List.iter (fun pos -> emit pos ()) data.decl_positions) () in let external_refs = join ~name:"external_refs" refs decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_opt -> - match decl_opt with - | Some () -> [] - | None -> [(posTo, ())]) + ~f:(fun _posFrom posTo decl_mb emit -> + if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () 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 @@ -94,27 +94,33 @@ let test_multi_level_union () = (* 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) + ~f:(fun _file (data : file_data) emit -> + List.iter + (fun (k, v) -> if String.length k > 0 && k.[0] = 'D' then emit k 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) + ~f:(fun _file (data : file_data) emit -> + List.iter + (fun (k, v) -> if String.length k > 0 && k.[0] = 'I' then emit k v) + data.refs) () in (* refs2: level 2 *) - let refs2 = flatMap ~name:"refs2" intermediate ~f:(fun k v -> [(k, v)]) () in + let refs2 = + flatMap ~name:"refs2" intermediate ~f:(fun k v emit -> emit 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) + ~f:(fun _file (data : file_data) emit -> + List.iter (fun pos -> emit pos ()) data.decl_positions) () in @@ -125,21 +131,16 @@ let test_multi_level_union () = let external_refs = join ~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, ())]) + ~f:(fun _posFrom posTo decl_mb emit -> + if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () 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 @@ -159,30 +160,32 @@ let test_real_pipeline_simulation () = (* decls: level 1 *) let decls = flatMap ~name:"decls" src - ~f:(fun _file (data : full_file_data) -> - List.map (fun pos -> (pos, ())) data.full_decls) + ~f:(fun _file (data : full_file_data) emit -> + List.iter (fun pos -> emit pos ()) 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) + ~f:(fun _file (data : full_file_data) emit -> + List.iter (fun (k, v) -> emit k 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) + ~f:(fun _file (data : full_file_data) emit -> + List.iter (fun (k, v) -> emit k 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 []) + ~f:(fun pos () emit -> + if String.length pos > 0 && pos.[0] = 'E' then emit pos ()) () in @@ -190,17 +193,15 @@ let test_real_pipeline_simulation () = let resolved_exception_refs = join ~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 emit -> + if ReactiveMaybe.is_some decl_mb then emit 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)]) + ~f:(fun posTo posFrom emit -> emit posFrom posTo) () in @@ -213,26 +214,20 @@ let test_real_pipeline_simulation () = let external_value_refs = join ~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, ())]) + ~f:(fun _posFrom posTo decl_mb emit -> + if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () 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); @@ -251,10 +246,8 @@ let test_separate_sources () = let external_refs = join ~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, ())]) + ~f:(fun _posFrom posTo decl_mb emit -> + if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () in @@ -262,13 +255,13 @@ let test_separate_sources () = 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 428a1b2f8e5..fafdcb1dc67 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -16,7 +16,7 @@ let test_file_collection () = (* First flatMap: aggregate word counts across files with merge *) let word_counts = flatMap ~name:"word_counts" files - ~f:(fun _path counts -> StringMap.bindings counts) + ~f:(fun _path counts emit -> StringMap.iter (fun k v -> emit k v) counts) (* Each file contributes its word counts *) ~merge:( + ) (* Sum counts from multiple files *) () @@ -25,7 +25,7 @@ let test_file_collection () = (* 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 []) + ~f:(fun word count emit -> if count >= 2 then emit word count) () in @@ -36,8 +36,8 @@ 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; @@ -46,21 +46,21 @@ let test_file_collection () = iter (fun word count -> Printf.printf " %s: %d\n" word 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; @@ -69,14 +69,14 @@ let test_file_collection () = iter (fun word count -> Printf.printf " %s: %d\n" word 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 70c4eb6136d..ed38cc8f408 100644 --- a/analysis/reactive/test/JoinTest.ml +++ b/analysis/reactive/test/JoinTest.ml @@ -1,6 +1,7 @@ (** Join combinator tests *) open Reactive +open TestHelpers let test_join () = reset (); @@ -16,12 +17,9 @@ let test_join () = let joined = join ~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 emit -> + if ReactiveMaybe.is_some decl_pos_mb then + emit (ReactiveMaybe.unsafe_get decl_pos_mb) loc_from) () in @@ -29,47 +27,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" @@ -85,33 +83,32 @@ let test_join_with_merge () = let joined = join ~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 -> []) + ~f:(fun _id _path value_mb emit -> + if ReactiveMaybe.is_some value_mb then + emit 0 (ReactiveMaybe.unsafe_get value_mb)) ~merge:( + ) (* 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 e94162f2b11..388447b0f35 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 54067172fe0..157b64df71c 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -2,33 +2,70 @@ 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) ReactiveWave.t = + ReactiveWave.create ~max_entries:65_536 -(* subscribe takes collection first in V2, but we want handler first for compatibility *) -let subscribe handler t = t.subscribe handler +let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave + +(** Emit a single set entry *) +let emit_set emit k v = + let w = wave () in + ReactiveWave.clear w; + ReactiveWave.push w k (ReactiveMaybe.some v); + emit w -(* emit_batch: emit a batch delta to a source *) -let emit_batch entries emit_fn = emit_fn (Batch entries) +(** Emit a single remove entry *) +let emit_remove emit k = + let w = wave () in + ReactiveWave.clear w; + ReactiveWave.push w k ReactiveMaybe.none; + emit w + +(** Emit a batch of (key, value) set entries *) +let emit_sets emit entries = + let w = wave () in + ReactiveWave.clear w; + List.iter (fun (k, v) -> ReactiveWave.push w k (ReactiveMaybe.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 + ReactiveWave.clear w; + List.iter + (fun (k, v_opt) -> + match v_opt with + | Some v -> ReactiveWave.push w k (ReactiveMaybe.some v) + | None -> ReactiveWave.push w k ReactiveMaybe.none) + 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 + ReactiveWave.iter wave (fun k mv -> + 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 ReactiveMaybe.is_some mv then added := k :: !added + else removed := k :: !removed) entries in (added, removed, handler) @@ -51,6 +88,11 @@ 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 *) +let get_opt t k = ReactiveMaybe.to_option (get t k) + (** {1 Common set modules} *) module IntSet = Set.Make (Int) diff --git a/analysis/reactive/test/UnionTest.ml b/analysis/reactive/test/UnionTest.ml index c5321803893..ea9851ecae2 100644 --- a/analysis/reactive/test/UnionTest.ml +++ b/analysis/reactive/test/UnionTest.ml @@ -20,41 +20,41 @@ let test_union_basic () = 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" @@ -72,29 +72,29 @@ let test_union_with_merge () = let combined = union ~name:"combined" left right ~merge:IntSet.union () 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])); @@ -107,30 +107,50 @@ let test_union_existing_data () = (* Create collections with existing data *) let left, emit_left = source ~name:"left" () in - emit_left (Set (1, "a")); - emit_left (Set (2, "b")); + 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")); + 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 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 ~name:"left" () in + emit_set emit_left "only_left" 3; + + let right, _emit_right = source ~name:"right" () in + + (* Create union after left already has data. + With merge = (+), a left-only key must stay 3, not 6. *) + let combined = union ~name:"combined" left right ~merge:( + ) () 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 cd8fe3ad9cf..e7b34c15b93 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 b34dbce8e77..7987c4fb24c 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 pos in + ReactiveMaybe.is_some mb + && ReactiveMaybe.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 pos in + ReactiveMaybe.is_some mb + && + let v = ReactiveMaybe.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 pos in + ReactiveMaybe.is_some mb + && + let v = ReactiveMaybe.unsafe_get mb in + v = FileAnnotations.Dead || v = FileAnnotations.GenType diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index a2434473c0e..fc9a4620f67 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -481,7 +481,7 @@ 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 = ReactiveMaybe.is_some (Reactive.get live pos) in (* hasRefBelow uses on-demand search through value_refs_from *) let hasRefBelow = @@ -522,7 +522,7 @@ 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 ReactiveMaybe.is_some (Reactive.get roots 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 7b0043c541e..a8b06da5087 100644 --- a/analysis/reanalyze/src/DeclarationStore.ml +++ b/analysis/reanalyze/src/DeclarationStore.ml @@ -17,7 +17,7 @@ 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 -> ReactiveMaybe.to_option (Reactive.get reactive pos) let fold f t init = match t with diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index eafd54a40ad..e11a6f2776c 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -138,10 +138,10 @@ let to_file_data_collection (collection : t) : (string, DceFileProcessing.file_data option) Reactive.t = Reactive.flatMap ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) - ~f:(fun path result_opt -> + ~f:(fun path result_opt emit -> match result_opt with - | Some {dce_data = Some data; _} -> [(path, Some data)] - | _ -> [(path, None)]) + | Some {dce_data = Some data; _} -> emit path (Some data) + | _ -> emit path None) () (** Iterate over all file_data in the collection *) diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index 9f5a2ea26c9..28ca500f147 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -15,7 +15,7 @@ let create ~(decls : (Lexing.position, Decl.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)])]) + ~f:(fun pos decl emit -> emit pos.Lexing.pos_fname [(pos, decl)]) ~merge:( @ ) () in @@ -31,28 +31,26 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.join ~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)) + ~f:(fun posFrom targets decls_mb emit -> + if ReactiveMaybe.is_some decls_mb then + let decls_in_file = ReactiveMaybe.unsafe_get decls_mb in + List.iter + (fun (decl_pos, decl) -> + if pos_in_decl posFrom decl then emit decl_pos targets) + decls_in_file) ~merge:PosSet.union () 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)) + ~f:(fun posFrom targets decls_mb emit -> + if ReactiveMaybe.is_some decls_mb then + let decls_in_file = ReactiveMaybe.unsafe_get decls_mb in + List.iter + (fun (decl_pos, decl) -> + if pos_in_decl posFrom decl then emit decl_pos targets) + decls_in_file) ~merge:PosSet.union () in @@ -61,23 +59,35 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let with_value_refs : (Lexing.position, PosSet.t) Reactive.t = Reactive.join ~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 emit -> + let refs = + if ReactiveMaybe.is_some refs_mb then ReactiveMaybe.unsafe_get refs_mb + else PosSet.empty + in + emit pos refs) () in let with_type_refs : (Lexing.position, PosSet.t) Reactive.t = Reactive.join ~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 emit -> + let refs = + if ReactiveMaybe.is_some refs_mb then ReactiveMaybe.unsafe_get refs_mb + else PosSet.empty + in + emit pos refs) () in (* Combine into final (value_targets, type_targets) pairs *) Reactive.join ~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 emit -> + let type_targets = + if ReactiveMaybe.is_some type_targets_mb then + ReactiveMaybe.unsafe_get type_targets_mb + else PosSet.empty + in + emit pos (value_targets, type_targets)) () diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index 81e23bfbe60..1d0b3a3fccc 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -27,7 +27,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.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) -> + ~f:(fun _pos (decl : Decl.t) emit -> match decl.Decl.declKind with | Exception -> let loc : Location.t = @@ -37,8 +37,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) loc_ghost = false; } in - [(decl.path, loc)] - | _ -> []) + emit decl.path loc + | _ -> ()) () (* Last-write-wins is fine since paths should be unique *) in @@ -46,24 +46,22 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let resolved_refs = Reactive.join ~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 emit -> + if ReactiveMaybe.is_some loc_to_mb then + let loc_to = ReactiveMaybe.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 -> []) + emit loc_to.Location.loc_start + (PosSet.singleton loc_from.Location.loc_start)) ~merge:PosSet.union () 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))) + ~f:(fun posTo posFromSet emit -> + PosSet.iter + (fun posFrom -> emit posFrom (PosSet.singleton posTo)) + posFromSet) ~merge:PosSet.union () in diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 4322bd09926..e380978e08f 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -37,9 +37,9 @@ let create ~(merged : ReactiveMerge.t) : t = (* 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) -> + ~f:(fun pos (value_targets, type_targets) emit -> let all_targets = PosSet.union value_targets type_targets in - [(pos, PosSet.elements all_targets)]) + emit pos (PosSet.elements all_targets)) () in @@ -57,14 +57,10 @@ let create ~(merged : ReactiveMerge.t) : t = let external_value_refs : (Lexing.position, unit) Reactive.t = Reactive.join ~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 emit -> + if not (ReactiveMaybe.is_some decl_mb) then (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun posTo -> (posTo, ()))) + PosSet.elements targets |> List.iter (fun posTo -> emit posTo ())) ~merge:(fun () () -> ()) () in @@ -72,14 +68,10 @@ let create ~(merged : ReactiveMerge.t) : t = let external_type_refs : (Lexing.position, unit) Reactive.t = Reactive.join ~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 emit -> + if not (ReactiveMaybe.is_some decl_mb) then (* posFrom is NOT a decl position, targets are externally referenced *) - PosSet.elements targets |> List.map (fun posTo -> (posTo, ()))) + PosSet.elements targets |> List.iter (fun posTo -> emit posTo ())) ~merge:(fun () () -> ()) () in @@ -95,11 +87,11 @@ let create ~(merged : ReactiveMerge.t) : t = let annotated_roots : (Lexing.position, unit) Reactive.t = Reactive.join ~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, ())] - | _ -> []) + ~f:(fun pos _decl ann_mb emit -> + if ReactiveMaybe.is_some ann_mb then + match ReactiveMaybe.unsafe_get ann_mb with + | FileAnnotations.Live | FileAnnotations.GenType -> emit pos () + | _ -> ()) ~merge:(fun () () -> ()) () in diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index f0a340f6c15..0be82271f91 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -26,61 +26,65 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Declarations: (pos, Decl.t) with last-write-wins *) let decls = Reactive.flatMap ~name:"decls" source - ~f:(fun _path file_data_opt -> + ~f:(fun _path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> - Declarations.builder_to_list file_data.DceFileProcessing.decls) + Declarations.builder_to_list file_data.DceFileProcessing.decls + |> List.iter (fun (k, v) -> emit k v)) () in (* Annotations: (pos, annotated_as) with last-write-wins *) let annotations = Reactive.flatMap ~name:"annotations" source - ~f:(fun _path file_data_opt -> + ~f:(fun _path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> FileAnnotations.builder_to_list - file_data.DceFileProcessing.annotations) + file_data.DceFileProcessing.annotations + |> List.iter (fun (k, v) -> emit k 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 -> + ~f:(fun _path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> References.builder_value_refs_from_list - file_data.DceFileProcessing.refs) + file_data.DceFileProcessing.refs + |> List.iter (fun (k, v) -> emit k v)) ~merge:PosSet.union () 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 -> + ~f:(fun _path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> References.builder_type_refs_from_list - file_data.DceFileProcessing.refs) + file_data.DceFileProcessing.refs + |> List.iter (fun (k, v) -> emit k v)) ~merge:PosSet.union () 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 -> + ~f:(fun path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> let items = CrossFileItems.builder_to_t file_data.DceFileProcessing.cross_file in - [(path, items)]) + emit path items) ~merge:(fun a b -> CrossFileItems. { @@ -94,36 +98,37 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* 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 -> + ~f:(fun _path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> - FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps) + FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps + |> List.iter (fun (k, v) -> emit k v)) ~merge:FileSet.union () 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 -> + ~f:(fun _cmt_path file_data_opt emit -> match file_data_opt with - | None -> [] + | None -> () | Some file_data -> (* Include all source files from file_deps (NOT the CMT path) *) 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 -> emit f ()) 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 -> + ~f:(fun _path items emit -> items.CrossFileItems.exception_refs - |> List.map (fun (r : CrossFileItems.exception_ref) -> - (r.exception_path, r.loc_from))) + |> List.iter (fun (r : CrossFileItems.exception_ref) -> + emit r.exception_path r.loc_from)) () in diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index dbe21b2b43c..818ce0e2567 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -57,10 +57,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let dead_decls = Reactive.join ~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 emit -> + if not (ReactiveMaybe.is_some live_mb) then emit pos decl) () in @@ -68,10 +66,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let live_decls = Reactive.join ~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 emit -> + if ReactiveMaybe.is_some live_mb then emit pos decl) () in @@ -80,41 +76,38 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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 _ _ -> []) + ~f:(fun _k _v _emit -> ()) () 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) ); - ]) + ~f:(fun _pos decl emit -> + emit (decl_module_name decl) + (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, ())]) + ~f:(fun _pos decl emit -> emit (decl_module_name decl) ()) () in (* Anti-join: modules in dead but not in live *) Reactive.join ~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 *) + ~f:(fun modName (loc, fileName) live_mb emit -> + if not (ReactiveMaybe.is_some live_mb) then + emit modName (loc, fileName) (* 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])]) + ~f:(fun _pos decl emit -> emit decl.pos.Lexing.pos_fname [decl]) ~merge:(fun decls1 decls2 -> decls1 @ decls2) () in @@ -130,11 +123,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 decl.pos in + if ReactiveMaybe.is_some ann then + match ReactiveMaybe.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 = @@ -170,20 +165,21 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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)]) + ~f:(fun file decls emit -> emit file (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 -> [((), ())]) + ~f:(fun _posFrom _targets emit -> emit () ()) ~merge:(fun _ _ -> ()) () 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)]) + ~f:(fun file decls _token_mb emit -> + emit file (issues_for_file file decls)) () in @@ -191,18 +187,19 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let incorrect_dead_decls = Reactive.join ~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 emit -> + if ReactiveMaybe.is_some ann_mb then + match ReactiveMaybe.unsafe_get ann_mb with + | FileAnnotations.Dead -> emit 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) + ~f:(fun _file (_issues, modules_list) emit -> + List.iter (fun m -> emit m ()) modules_list) () in @@ -211,9 +208,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.join ~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 () -> + ~f:(fun moduleName (loc, fileName) has_reported_mb emit -> + if ReactiveMaybe.is_some has_reported_mb then let loc = if loc.Location.loc_ghost then let pos = @@ -227,8 +223,8 @@ 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 -> []) + emit moduleName + (AnalysisResult.make_dead_module_issue ~loc ~moduleName)) () in @@ -254,8 +250,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 moduleName in + if ReactiveMaybe.is_some dm then ( + let loc, fileName = ReactiveMaybe.unsafe_get dm in Hashtbl.replace reported_modules moduleName (); let loc = if loc.Location.loc_ghost then @@ -267,8 +264,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. @@ -334,9 +331,10 @@ let iter_live_decls ~(t : t) (f : Decl.t -> unit) : unit = (** 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 d = Reactive.get t.decls pos in + if not (ReactiveMaybe.is_some d) then true + (* not a declaration, assume live *) + else ReactiveMaybe.is_some (Reactive.get t.live pos) (** Stats *) let stats ~(t : t) : int * int = diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 5fd0694405b..30f68183926 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -50,31 +50,30 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 1: Index decls by path *) let decl_by_path = Reactive.flatMap ~name:"type_deps.decl_by_path" decls - ~f:(fun _pos decl -> + ~f:(fun _pos decl emit -> match decl_to_info decl with - | Some info -> [(info.path, [info])] - | None -> []) + | Some info -> emit info.path [info] + | None -> ()) ~merge:List.append () 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 -> + ~f:(fun _path decls emit -> 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 -> + |> List.iter (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 + emit other.pos (PosSet.singleton first.pos); + if not report_types_dead_only_in_interface then (* Also add: first -> other (posTo=first, posFrom=other) *) - (first.pos, PosSet.singleton other.pos) :: refs)) + emit first.pos (PosSet.singleton other.pos))) ~merge:PosSet.union () in @@ -82,19 +81,19 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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 -> + ~f:(fun _pos decl emit -> 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))]) - | _ -> []) + emit info.pos (info, intf_path1, intf_path2)) + | _ -> ()) () in @@ -104,16 +103,16 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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 - | _ -> []) + ~f:(fun _pos (info, _intf_path1, _intf_path2) intf_decls_mb emit -> + if ReactiveMaybe.is_some intf_decls_mb then + match ReactiveMaybe.unsafe_get intf_decls_mb with + | intf_info :: _ -> + (* Found at path1: posTo=impl, posFrom=intf *) + emit info.pos (PosSet.singleton intf_info.pos); + if not report_types_dead_only_in_interface then + (* Also: posTo=intf, posFrom=impl *) + emit intf_info.pos (PosSet.singleton info.pos) + | [] -> ()) ~merge:PosSet.union () in @@ -121,10 +120,15 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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))]) + ~f:(fun pos (info, _intf_path1, intf_path2) intf_decls_mb emit -> + let found = + ReactiveMaybe.is_some intf_decls_mb + && + match ReactiveMaybe.unsafe_get intf_decls_mb with + | _ :: _ -> true + | [] -> false + in + if not found then emit pos (info, intf_path2)) () in @@ -132,14 +136,15 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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 - | _ -> []) + ~f:(fun _pos (info, _) intf_decls_mb emit -> + if ReactiveMaybe.is_some intf_decls_mb then + match ReactiveMaybe.unsafe_get intf_decls_mb with + | intf_info :: _ -> + (* posTo=impl, posFrom=intf *) + emit info.pos (PosSet.singleton intf_info.pos); + if not report_types_dead_only_in_interface then + emit intf_info.pos (PosSet.singleton info.pos) + | [] -> ()) ~merge:PosSet.union () in @@ -150,44 +155,45 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) and the lookup is for finding the impl. *) let intf_decls = Reactive.flatMap ~name:"type_deps.intf_decls" decls - ~f:(fun _pos decl -> + ~f:(fun _pos decl emit -> 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))]) - | _ -> []) + emit info.pos (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 - | _ -> []) + ~f:(fun _pos (intf_info, _) impl_decls_mb emit -> + if ReactiveMaybe.is_some impl_decls_mb then + match ReactiveMaybe.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 + *) + emit impl_info.pos (PosSet.singleton intf_info.pos); + if not report_types_dead_only_in_interface then + emit intf_info.pos (PosSet.singleton impl_info.pos) + | [] -> ()) ~merge:PosSet.union () in @@ -219,9 +225,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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))) + ~f:(fun posTo posFromSet emit -> + PosSet.iter + (fun posFrom -> emit posFrom (PosSet.singleton posTo)) + posFromSet) ~merge:PosSet.union () in diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index 64db1247b0d..ea4d6d046c9 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -340,7 +340,8 @@ 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 + ReactiveMaybe.to_option + (Reactive.get merged.ReactiveMerge.decls pos) 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 09ceb3f5ec5..4db84806037 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 b6b1d28008f..3c33f799095 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 d9e420bd2bc..78ca46a877d 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() { @@ -346,24 +332,6 @@ PY time_end "json_compare" } -set_config_suppress_all() { - python3 - < Date: Fri, 6 Mar 2026 12:07:13 +0100 Subject: [PATCH 02/54] analysis/reactive: add off-heap allocator and table Signed-off-by: Cristiano Calcagno --- analysis/reactive/src/ReactiveAllocator.ml | 75 ++++++++ analysis/reactive/src/ReactiveAllocator.mli | 74 ++++++++ analysis/reactive/src/ReactiveTable.ml | 61 +++++++ analysis/reactive/src/ReactiveTable.mli | 45 +++++ analysis/reactive/src/dune | 3 + .../reactive/src/reactive_allocator_stubs.c | 169 ++++++++++++++++++ analysis/reactive/test/ReactiveTest.ml | 1 + analysis/reactive/test/TableTest.ml | 149 +++++++++++++++ analysis/reactive/test/dune | 5 +- 9 files changed, 580 insertions(+), 2 deletions(-) create mode 100644 analysis/reactive/src/ReactiveAllocator.ml create mode 100644 analysis/reactive/src/ReactiveAllocator.mli create mode 100644 analysis/reactive/src/ReactiveTable.ml create mode 100644 analysis/reactive/src/ReactiveTable.mli create mode 100644 analysis/reactive/src/reactive_allocator_stubs.c create mode 100644 analysis/reactive/test/TableTest.ml diff --git a/analysis/reactive/src/ReactiveAllocator.ml b/analysis/reactive/src/ReactiveAllocator.ml new file mode 100644 index 00000000000..27a6672affa --- /dev/null +++ b/analysis/reactive/src/ReactiveAllocator.ml @@ -0,0 +1,75 @@ +type 'a offheap = 'a + +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 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 () +let unsafe_to_offheap x = x +let unsafe_from_offheap x = x + +let to_offheap x = + if is_in_minor_heap x then invalid_arg "ReactiveAllocator.to_offheap"; + unsafe_to_offheap x + +module Block = struct + type t = int + + external create_unsafe : int -> t = "caml_reactive_allocator_create" + [@@noalloc] + + external destroy : t -> unit = "caml_reactive_allocator_destroy" [@@noalloc] + external capacity : t -> int = "caml_reactive_allocator_capacity" [@@noalloc] + external resize_unsafe : t -> int -> unit = "caml_reactive_allocator_resize" + [@@noalloc] + + external unsafe_get : t -> int -> 'a offheap = "caml_reactive_allocator_get" + [@@noalloc] + + external unsafe_set : t -> int -> 'a offheap -> unit = + "caml_reactive_allocator_set" + [@@noalloc] + + external blit_unsafe : + t -> int -> t -> int -> int -> unit = "caml_reactive_allocator_blit" + [@@noalloc] + + let create ~capacity = + check_non_negative "ReactiveAllocator.Block.create" capacity; + create_unsafe capacity + + let resize block ~capacity = + check_non_negative "ReactiveAllocator.Block.resize" capacity; + resize_unsafe block capacity + + let get block index = + let cap = capacity block in + if index < 0 || index >= cap then invalid_arg "ReactiveAllocator.Block.get"; + unsafe_get block index + + let set block index value = + let cap = capacity block in + if index < 0 || index >= cap then invalid_arg "ReactiveAllocator.Block.set"; + unsafe_set block index value + + let blit ~src ~src_pos ~dst ~dst_pos ~len = + check_non_negative "ReactiveAllocator.Block.blit" src_pos; + check_non_negative "ReactiveAllocator.Block.blit" dst_pos; + check_non_negative "ReactiveAllocator.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 "ReactiveAllocator.Block.blit"; + blit_unsafe src src_pos dst dst_pos len +end diff --git a/analysis/reactive/src/ReactiveAllocator.mli b/analysis/reactive/src/ReactiveAllocator.mli new file mode 100644 index 00000000000..3454f91c435 --- /dev/null +++ b/analysis/reactive/src/ReactiveAllocator.mli @@ -0,0 +1,74 @@ +(** Off-heap storage for raw OCaml values. + + Main concepts: + - A [block] is an off-heap 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. *) + +type 'a offheap +(** A value intended to be stored in off-heap structures. + + This type does not prove safety. It marks values that are crossing the + off-heap boundary so call sites can be audited explicitly. *) + +val unsafe_to_offheap : 'a -> 'a offheap +(** Unsafely mark a value as suitable for off-heap storage. The caller must + ensure the allocator invariants hold. *) + +val to_offheap : 'a -> 'a offheap +(** Safely mark a value as suitable for off-heap storage. + + Raises [Invalid_argument] if the value is currently in the minor heap. + Immediates are accepted. *) + +val unsafe_from_offheap : 'a offheap -> 'a +(** Unsafely recover a regular OCaml value from an off-heap-marked value. *) + +module Block : sig + type t + + val create : capacity:int -> t + (** Allocate an off-heap block of raw OCaml value slots. *) + + val destroy : t -> unit + (** Release the block storage. The handle must not be used afterwards. *) + + val capacity : t -> int + (** Current block size, in slots. *) + + val resize : t -> capacity:int -> unit + (** Resize the block, preserving the prefix up to the new capacity. *) + + val get : t -> int -> 'a offheap + (** Read a slot. The caller is responsible for keeping pointed-to values + alive and out of the minor heap while stored off-heap. *) + + val set : t -> int -> 'a offheap -> unit + (** Write a slot. *) + + val blit : + src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit + (** Copy a range of raw value slots between blocks. *) +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 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 off-heap storage + invariant in tests and debug code, and by [to_offheap]. *) diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml new file mode 100644 index 00000000000..ac39592abb2 --- /dev/null +++ b/analysis/reactive/src/ReactiveTable.ml @@ -0,0 +1,61 @@ +type 'a t = ReactiveAllocator.Block.t + +let length_slot = 0 +let data_offset = 1 + +let length t : int = + ReactiveAllocator.unsafe_from_offheap + (ReactiveAllocator.Block.get t length_slot) + +let capacity t = ReactiveAllocator.Block.capacity t - data_offset + +let create ~initial_capacity = + if initial_capacity < 0 then invalid_arg "ReactiveTable.create"; + let t = + ReactiveAllocator.Block.create ~capacity:(initial_capacity + data_offset) + in + ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.unsafe_to_offheap 0); + t + +let destroy = ReactiveAllocator.Block.destroy + +let clear t = + ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.unsafe_to_offheap 0) + +let ensure_capacity t needed = + let old_capacity = capacity t in + if needed > old_capacity then ( + let new_capacity = ref (max 1 old_capacity) in + while !new_capacity < needed do + new_capacity := !new_capacity * 2 + done; + ReactiveAllocator.Block.resize t ~capacity:(!new_capacity + data_offset)) + +let get t index = + let len = length t in + if index < 0 || index >= len then invalid_arg "ReactiveTable.get"; + ReactiveAllocator.Block.get t (index + data_offset) + +let set t index value = + let len = length t in + if index < 0 || index >= len then invalid_arg "ReactiveTable.set"; + ReactiveAllocator.Block.set t (index + data_offset) value + +let push t value = + let len = length t in + let next_len = len + 1 in + ensure_capacity t next_len; + ReactiveAllocator.Block.set t (len + data_offset) value; + ReactiveAllocator.Block.set t length_slot + (ReactiveAllocator.unsafe_to_offheap next_len) + +let pop t = + let len = length t in + if len = 0 then invalid_arg "ReactiveTable.pop"; + let last = ReactiveAllocator.Block.get t (len - 1 + data_offset) in + ReactiveAllocator.Block.set t length_slot + (ReactiveAllocator.unsafe_to_offheap (len - 1)); + last + +let shrink_to_fit t = + ReactiveAllocator.Block.resize t ~capacity:(length t + data_offset) diff --git a/analysis/reactive/src/ReactiveTable.mli b/analysis/reactive/src/ReactiveTable.mli new file mode 100644 index 00000000000..0249cdfc7cc --- /dev/null +++ b/analysis/reactive/src/ReactiveTable.mli @@ -0,0 +1,45 @@ +type 'a t + +val create : initial_capacity:int -> 'a t +(** Create an extensible off-heap table. + + Stored values are raw OCaml values kept outside the GC's scanned heap. + This is only safe for immediates, or for heap values that are: + 1. promoted out of the minor heap, and + 2. kept reachable through normal OCaml roots elsewhere. + + Intended reactive protocol: + 1. Produce a wave of fresh OCaml values on the heap. + 2. Promote them out of the minor heap before off-heap publication. + 3. Insert them into off-heap reactive tables during the allocation-free + processing phase. + 4. After the iteration finishes, flush/remove table entries as needed. + 5. Only then drop the ordinary OCaml roots for removed values. + + Violating this protocol is unsafe: + - minor-heap values may move, leaving stale pointers off-heap + - unrooted major-heap values may be reclaimed *) + +val destroy : 'a t -> unit +(** Release the table storage. The handle must not be used afterwards. *) + +val length : 'a t -> int +(** Number of elements currently stored in the table. *) + +val capacity : 'a t -> int +(** Current table capacity, in elements. *) + +val clear : 'a t -> unit +(** Remove all elements from the table without releasing its storage. *) + +val get : 'a t -> int -> 'a ReactiveAllocator.offheap +val set : 'a t -> int -> 'a ReactiveAllocator.offheap -> unit + +val push : 'a t -> 'a ReactiveAllocator.offheap -> unit +(** Append an element, growing via the allocator when needed. *) + +val pop : 'a t -> 'a ReactiveAllocator.offheap +(** Remove and return the last element. *) + +val shrink_to_fit : 'a t -> unit +(** Shrink storage capacity down to the current length. *) diff --git a/analysis/reactive/src/dune b/analysis/reactive/src/dune index 6c699f4cce4..f8da2881ed7 100644 --- a/analysis/reactive/src/dune +++ b/analysis/reactive/src/dune @@ -2,4 +2,7 @@ (name reactive) (wrapped false) (private_modules ReactiveQueue) + (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 00000000000..d8dd89b054d --- /dev/null +++ b/analysis/reactive/src/reactive_allocator_stubs.c @@ -0,0 +1,169 @@ +#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_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/ReactiveTest.ml b/analysis/reactive/test/ReactiveTest.ml index 388447b0f35..8f628e84ba8 100644 --- a/analysis/reactive/test/ReactiveTest.ml +++ b/analysis/reactive/test/ReactiveTest.ml @@ -11,4 +11,5 @@ let () = IntegrationTest.run_all (); GlitchFreeTest.run_all (); AllocTest.run_all (); + TableTest.run_all (); Printf.printf "\nAll tests passed!\n" diff --git a/analysis/reactive/test/TableTest.ml b/analysis/reactive/test/TableTest.ml new file mode 100644 index 00000000000..0646f2a9eb1 --- /dev/null +++ b/analysis/reactive/test/TableTest.ml @@ -0,0 +1,149 @@ +(** Tests for off-heap ReactiveTable storage. *) + +let test_table_promoted_wave_lifecycle () = + Printf.printf "=== Test: table promoted-wave lifecycle ===\n"; + let iterations = 8 in + let count = 128 in + let width = 48 in + let initial_live_blocks = ReactiveAllocator.live_block_count () in + let initial_live_block_slots = ReactiveAllocator.live_block_capacity_slots () in + Gc.full_major (); + ignore (AllocMeasure.words_since ()); + let t = ReactiveTable.create ~initial_capacity:1 in + let create_words = AllocMeasure.words_since () in + assert (create_words = 0); + for iter = 1 to iterations do + ignore (AllocMeasure.words_since ()); + let fresh = + Array.init count (fun i -> + let c = Char.chr (((iter + i) mod 26) + Char.code 'a') in + let bytes = Bytes.make width c in + Bytes.set bytes 0 c; + Bytes.set bytes (width - 1) c; + bytes) + in + let produced_words = AllocMeasure.words_since () in + assert (produced_words > 0); + + for i = 0 to count - 1 do + assert (ReactiveAllocator.is_in_minor_heap fresh.(i)) + done; + + Gc.full_major (); + + for i = 0 to count - 1 do + assert (not (ReactiveAllocator.is_in_minor_heap fresh.(i))) + done; + + ignore (AllocMeasure.words_since ()); + ReactiveTable.clear t; + for i = 0 to count - 1 do + ReactiveTable.push t (ReactiveAllocator.to_offheap fresh.(i)) + done; + assert (ReactiveTable.length t = count); + assert (ReactiveTable.capacity t >= ReactiveTable.length t); + ReactiveTable.set t 0 + (ReactiveAllocator.to_offheap fresh.(count - 1)); + assert ( + ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t 0) + == fresh.(count - 1)); + for i = 0 to count - 1 do + let expected = if i = 0 then fresh.(count - 1) else fresh.(i) in + let recovered = + ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t i) + in + assert (recovered == expected); + assert (Bytes.get recovered 0 = Bytes.get expected 0); + assert (Bytes.get recovered (width - 1) = Bytes.get expected (width - 1)) + done; + assert ( + ReactiveAllocator.unsafe_from_offheap (ReactiveTable.pop t) + == fresh.(count - 1)); + assert (ReactiveTable.length t = count - 1); + ReactiveTable.shrink_to_fit t; + assert (ReactiveTable.capacity t = ReactiveTable.length t); + ReactiveTable.clear t; + assert (ReactiveTable.length t = 0); + let table_words = AllocMeasure.words_since () in + Printf.printf " iter=%d produced=%d table_phase=%d\n" iter produced_words + table_words; + assert (table_words = 0); + + Gc.full_major () + done; + ignore (AllocMeasure.words_since ()); + ReactiveTable.destroy t; + let teardown_words = AllocMeasure.words_since () in + assert (teardown_words = 0); + assert (ReactiveAllocator.live_block_count () = initial_live_blocks); + assert ( + ReactiveAllocator.live_block_capacity_slots () = initial_live_block_slots); + Printf.printf " create=%d teardown=%d\n" create_words teardown_words; + Printf.printf "PASSED\n\n" + +let test_table_unsafe_minor_heap_demo () = + Printf.printf "=== Test: table unsafe minor-heap demo ===\n"; + match Sys.getenv_opt "RESCRIPT_REACTIVE_RUN_UNSAFE_TABLE_DEMO" with + | None -> + Printf.printf + "SKIPPED (set RESCRIPT_REACTIVE_RUN_UNSAFE_TABLE_DEMO=1 to run)\n\n" + | Some _ -> + let count = 2048 in + let width = 64 in + let t = ReactiveTable.create ~initial_capacity:count in + (* Each [Bytes.make] result starts in the minor heap. We store only the raw + addresses off-heap and intentionally drop all OCaml roots. *) + for i = 0 to count - 1 do + let c = Char.chr ((i mod 26) + Char.code 'A') in + let fresh = Bytes.make width c in + Bytes.set fresh 0 c; + Bytes.set fresh (width - 1) c; + ReactiveTable.push t (ReactiveAllocator.unsafe_to_offheap fresh) + done; + Gc.compact (); + for round = 1 to 200 do + for j = 0 to 200 do + ignore (Bytes.make (1024 + ((round + j) mod 2048)) 'z') + done; + Gc.full_major (); + Gc.compact () + done; + Printf.printf + "About to validate %d minor-heap values stored off-heap. This is unsafe and may return garbage or crash.\n" + count; + let mismatches = ref 0 in + let samples = ref [] in + for i = 0 to count - 1 do + let expected = Char.chr ((i mod 26) + Char.code 'A') in + let recovered : bytes = + ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t i) + in + let ok = + Bytes.length recovered = width + && Bytes.get recovered 0 = expected + && Bytes.get recovered (width - 1) = expected + in + if not ok then ( + incr mismatches; + if List.length !samples < 8 then + let observed_len = + try Bytes.length recovered with _ -> -1 + in + let observed_first = + try Bytes.get recovered 0 with _ -> '?' + in + samples := + Printf.sprintf + "slot=%d expected=%c len=%d first=%c" + i expected observed_len observed_first + :: !samples) + done; + Printf.printf "Observed mismatches: %d/%d\n" !mismatches count; + List.iter (fun s -> Printf.printf "%s\n" s) (List.rev !samples); + ReactiveTable.destroy t; + Printf.printf + "UNSAFE DEMO COMPLETED (result is not trustworthy; crash/corruption would also be expected)\n\n" + +let run_all () = + test_table_promoted_wave_lifecycle (); + test_table_unsafe_minor_heap_demo () diff --git a/analysis/reactive/test/dune b/analysis/reactive/test/dune index e7b34c15b93..ec3ac28bdb5 100644 --- a/analysis/reactive/test/dune +++ b/analysis/reactive/test/dune @@ -10,7 +10,8 @@ FixpointIncrementalTest BatchTest IntegrationTest - GlitchFreeTest + GlitchFreeTest AllocMeasure - AllocTest) + AllocTest + TableTest) (libraries reactive)) From 08d58c2f915d69210815df4dc8120e89191a5a46 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 14:09:50 +0100 Subject: [PATCH 03/54] analysis/reactive: move waves to offheap values --- analysis/reactive/src/Reactive.ml | 56 +++++++++--- analysis/reactive/src/ReactiveAllocator.ml | 2 + analysis/reactive/src/ReactiveAllocator.mli | 6 ++ .../reactive/src/ReactiveFileCollection.ml | 18 ++-- analysis/reactive/src/ReactiveFixpoint.ml | 43 ++++++++-- analysis/reactive/src/ReactiveFlatMap.ml | 14 ++- analysis/reactive/src/ReactiveFlatMap.mli | 6 +- analysis/reactive/src/ReactiveJoin.ml | 20 ++++- analysis/reactive/src/ReactiveJoin.mli | 10 ++- analysis/reactive/src/ReactiveMaybe.ml | 11 ++- analysis/reactive/src/ReactiveMaybe.mli | 12 +++ analysis/reactive/src/ReactiveTable.ml | 8 +- analysis/reactive/src/ReactiveUnion.ml | 27 ++++-- analysis/reactive/src/ReactiveUnion.mli | 12 ++- analysis/reactive/src/ReactiveWave.ml | 85 +++++++++++++------ analysis/reactive/src/ReactiveWave.mli | 36 +++++++- analysis/reactive/test/AllocTest.ml | 73 ++++++++++------ analysis/reactive/test/GlitchFreeTest.ml | 2 + analysis/reactive/test/TestHelpers.ml | 24 ++++-- 19 files changed, 357 insertions(+), 108 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index b99a4c3bf46..bd23339e8f8 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -16,8 +16,8 @@ let wave_max_entries_default = | Some s -> ( match int_of_string_opt s with | Some n when n > 0 -> n - | _ -> 65_536) - | None -> 65_536 + | _ -> 16) + | None -> 16 let create_wave () = ReactiveWave.create ~max_entries:wave_max_entries_default @@ -471,6 +471,15 @@ let stats t = t.stats let level t = t.level let name t = t.name +let unsafe_wave_push wave k v = + ReactiveWave.push wave (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap v) + +let unsafe_wave_map_replace pending k v = + ReactiveHash.Map.replace pending + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v) + (** {1 Source Collection} *) (* Module-level helper for source emit — avoids closure allocation. @@ -480,8 +489,9 @@ type ('k, 'v) source_tables = { pending: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; } -let apply_source_emit (tables : ('k, 'v) source_tables) k - (mv : 'v ReactiveMaybe.t) = +let apply_source_emit (tables : ('k, 'v) source_tables) k mv = + let k = ReactiveAllocator.unsafe_from_offheap k in + let mv = ReactiveAllocator.unsafe_from_offheap mv in if ReactiveMaybe.is_some mv then ( let v = ReactiveMaybe.unsafe_get mv in ReactiveHash.Map.replace tables.tbl k v; @@ -509,7 +519,7 @@ let source ~name () = my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; my_stats.entries_emitted <- my_stats.entries_emitted + count; ReactiveWave.clear output_wave; - ReactiveHash.Map.iter_with ReactiveWave.push output_wave pending; + ReactiveHash.Map.iter_with unsafe_wave_push output_wave pending; ReactiveHash.Map.clear pending; notify_subscribers output_wave !subscribers) else ReactiveHash.Map.clear pending @@ -819,8 +829,8 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ReactiveWave.clear edge_wave; let root_entries = ReactiveHash.Map.cardinal root_pending in let edge_entries = ReactiveHash.Map.cardinal edge_pending in - ReactiveHash.Map.iter_with ReactiveWave.push root_wave root_pending; - ReactiveHash.Map.iter_with ReactiveWave.push edge_wave edge_pending; + ReactiveHash.Map.iter_with unsafe_wave_push root_wave root_pending; + ReactiveHash.Map.iter_with unsafe_wave_push edge_wave edge_pending; ReactiveHash.Map.clear root_pending; ReactiveHash.Map.clear edge_pending; @@ -851,13 +861,13 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : init.subscribe (fun wave -> Registry.inc_inflight_node init.node; init_pending_count := !init_pending_count + 1; - ReactiveWave.iter_with wave ReactiveHash.Map.replace root_pending; + ReactiveWave.iter_with wave unsafe_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; - ReactiveWave.iter_with wave ReactiveHash.Map.replace edge_pending; + ReactiveWave.iter_with wave unsafe_wave_map_replace edge_pending; Registry.mark_dirty_node my_info); (* Initialize from existing data *) @@ -867,10 +877,34 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : let init_edges_wave = ReactiveWave.create ~max_entries:(max 1 (edges.length ())) in + Printf.printf + "[Reactive.fixpoint] init existing data name=%s roots=%d edges=%d\n" name + (init.length ()) (edges.length ()); + flush_all (); ReactiveWave.clear init_roots_wave; ReactiveWave.clear init_edges_wave; - init.iter (fun k () -> ReactiveWave.push init_roots_wave k ()); - edges.iter (fun k succs -> ReactiveWave.push init_edges_wave k succs); + let init_root_count = ref 0 in + init.iter (fun k () -> + incr init_root_count; + if !init_root_count <= 5 || !init_root_count mod 100 = 0 then ( + Printf.printf + "[Reactive.fixpoint] init root push name=%s count=%d\n" name + !init_root_count; + flush_all ()); + unsafe_wave_push init_roots_wave k ()); + let init_edge_count = ref 0 in + edges.iter (fun k succs -> + incr init_edge_count; + if !init_edge_count <= 5 || !init_edge_count mod 100 = 0 then ( + Printf.printf + "[Reactive.fixpoint] init edge push name=%s count=%d\n" name + !init_edge_count; + flush_all ()); + unsafe_wave_push init_edges_wave k succs); + Printf.printf + "[Reactive.fixpoint] init existing data loaded name=%s roots=%d edges=%d\n" + name !init_root_count !init_edge_count; + flush_all (); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; diff --git a/analysis/reactive/src/ReactiveAllocator.ml b/analysis/reactive/src/ReactiveAllocator.ml index 27a6672affa..6c529a54d02 100644 --- a/analysis/reactive/src/ReactiveAllocator.ml +++ b/analysis/reactive/src/ReactiveAllocator.ml @@ -18,6 +18,8 @@ let check_non_negative name n = let slot_size_bytes = slot_size_bytes_unsafe () let unsafe_to_offheap x = x let unsafe_from_offheap x = x +let int_to_offheap x = unsafe_to_offheap x +let unit_to_offheap x = unsafe_to_offheap x let to_offheap x = if is_in_minor_heap x then invalid_arg "ReactiveAllocator.to_offheap"; diff --git a/analysis/reactive/src/ReactiveAllocator.mli b/analysis/reactive/src/ReactiveAllocator.mli index 3454f91c435..e3c027ccab2 100644 --- a/analysis/reactive/src/ReactiveAllocator.mli +++ b/analysis/reactive/src/ReactiveAllocator.mli @@ -29,6 +29,12 @@ val to_offheap : 'a -> 'a offheap Raises [Invalid_argument] if the value is currently in the minor heap. Immediates are accepted. *) +val int_to_offheap : int -> int offheap +(** Safely mark an [int] as suitable for off-heap storage. *) + +val unit_to_offheap : unit -> unit offheap +(** Safely mark [()] as suitable for off-heap storage. *) + val unsafe_from_offheap : 'a offheap -> 'a (** Unsafely recover a regular OCaml value from an off-heap-marked value. *) diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index ddb207da205..49047c57030 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -32,7 +32,7 @@ type ('raw, 'v) t = { 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 - let scratch_wave = ReactiveWave.create ~max_entries:65_536 in + let scratch_wave = ReactiveWave.create ~max_entries:16 in {internal; collection; emit; scratch_wave} (** Get the collection interface for composition *) @@ -41,7 +41,9 @@ let to_collection t : (string, 'v) Reactive.t = t.collection (** Emit a single set entry *) let emit_set t path value = ReactiveWave.clear t.scratch_wave; - ReactiveWave.push t.scratch_wave path (ReactiveMaybe.some value); + ReactiveWave.push t.scratch_wave + (ReactiveAllocator.unsafe_to_offheap path) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some value)); t.emit t.scratch_wave (** Process a file if changed. Emits delta to subscribers. *) @@ -75,7 +77,9 @@ let process_files_batch t paths = 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); - ReactiveWave.push t.scratch_wave path (ReactiveMaybe.some value); + ReactiveWave.push t.scratch_wave + (ReactiveAllocator.unsafe_to_offheap path) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some value)); incr count) paths; if !count > 0 then t.emit t.scratch_wave; @@ -85,7 +89,9 @@ let process_files_batch t paths = let remove t path = Hashtbl.remove t.internal.cache path; ReactiveWave.clear t.scratch_wave; - ReactiveWave.push t.scratch_wave path ReactiveMaybe.none; + ReactiveWave.push t.scratch_wave + (ReactiveAllocator.unsafe_to_offheap path) + ReactiveMaybe.none_offheap; t.emit t.scratch_wave (** Remove multiple files as a batch *) @@ -96,7 +102,9 @@ let remove_batch t paths = (fun path -> if Hashtbl.mem t.internal.cache path then ( Hashtbl.remove t.internal.cache path; - ReactiveWave.push t.scratch_wave path ReactiveMaybe.none; + ReactiveWave.push t.scratch_wave + (ReactiveAllocator.unsafe_to_offheap path) + ReactiveMaybe.none_offheap; incr count)) paths; if !count > 0 then t.emit t.scratch_wave; diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index f180f19e92d..e5c03fb0a24 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -495,9 +495,14 @@ let initialize t ~roots ~edges = ReactiveHash.Map.clear t.roots; ReactiveHash.Map.clear t.edge_map; ReactivePoolMapSet.clear t.pred_map; - ReactiveWave.iter roots (fun k () -> ReactiveHash.Map.replace t.roots k ()); + ReactiveWave.iter roots (fun k _ -> + ReactiveHash.Map.replace t.roots + (ReactiveAllocator.unsafe_from_offheap k) + ()); ReactiveWave.iter edges (fun k successors -> - apply_edge_update t ~src:k ~new_successors:successors); + apply_edge_update t + ~src:(ReactiveAllocator.unsafe_from_offheap k) + ~new_successors:(ReactiveAllocator.unsafe_from_offheap successors)); recompute_current t let is_supported t k = @@ -530,7 +535,9 @@ let add_live t k = if not (ReactiveHash.Map.mem t.current k) then ( ReactiveHash.Map.replace t.current k (); if not (ReactiveHash.Map.mem t.deleted_nodes k) then - ReactiveWave.push t.output_wave k (ReactiveMaybe.some ()); + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveMaybe.maybe_unit_to_offheap (ReactiveMaybe.some ())); enqueue_expand t k) let enqueue_rederive_if_needed t k = @@ -593,7 +600,9 @@ let apply_root_mutation t k mv = let emit_removal t k () = if not (ReactiveHash.Map.mem t.current k) then - ReactiveWave.push t.output_wave k ReactiveMaybe.none + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMaybe.none_offheap let rebuild_edge_change_queue t src _succs = ReactiveQueue.push t.edge_change_queue src @@ -621,11 +630,21 @@ let apply_list t ~roots ~edges = (* Phase 1a: scan init entries — seed delete queue for removed roots, buffer added roots for later expansion *) - ReactiveWave.iter_with roots scan_root_entry t; + ReactiveWave.iter_with roots + (fun t k mv -> + scan_root_entry t + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap mv)) + t; (* Phase 1b: scan edge entries — seed delete queue for removed targets, store new_succs and has_new_edge for later phases *) - ReactiveWave.iter_with edges scan_edge_entry t; + ReactiveWave.iter_with edges + (fun t src mv -> + scan_edge_entry t + (ReactiveAllocator.unsafe_from_offheap src) + (ReactiveAllocator.unsafe_from_offheap mv)) + t; Invariants.assert_edge_has_new_consistent ~edge_change_queue:t.edge_change_queue @@ -647,7 +666,12 @@ let apply_list t ~roots ~edges = ~deleted_nodes:t.deleted_nodes ~old_successors:(old_successors t); (* Phase 3: apply root and edge mutations *) - ReactiveWave.iter_with roots apply_root_mutation t; + ReactiveWave.iter_with roots + (fun t k mv -> + apply_root_mutation t + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap mv)) + t; (* Apply edge updates by draining edge_change_queue. *) while not (ReactiveQueue.is_empty t.edge_change_queue) do @@ -733,7 +757,10 @@ let apply_list t ~roots ~edges = if Invariants.enabled then ( let entries = ref [] in ReactiveWave.iter t.output_wave (fun k v_opt -> - entries := (k, v_opt) :: !entries); + entries := + ( ReactiveAllocator.unsafe_from_offheap k, + ReactiveAllocator.unsafe_from_offheap v_opt ) + :: !entries); !entries) else [] in diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index d16010061d2..d7fd9b833a8 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -76,7 +76,10 @@ let create ~f ~merge ~output_wave = in t -let push t k v_opt = ReactiveHash.Map.replace t.scratch k v_opt +let push t k v_opt = + ReactiveHash.Map.replace t.scratch + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v_opt) (* Remove one contribution key during remove_source iteration *) let remove_one_contribution (t : (_, _, _, _) t) k2 = @@ -101,10 +104,14 @@ let recompute_target (t : (_, _, _, _) t) k2 = ReactivePoolMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; ReactiveHash.Map.replace t.target k2 t.merge_acc; - ReactiveWave.push t.output_wave k2 (ReactiveMaybe.some t.merge_acc)) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k2) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some t.merge_acc))) else ( ReactiveHash.Map.remove t.target k2; - ReactiveWave.push t.output_wave k2 ReactiveMaybe.none) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k2) + ReactiveMaybe.none_offheap) (* Single-pass process + count for scratch *) let process_scratch_entry (t : (_, _, _, _) t) k1 mv = @@ -118,6 +125,7 @@ let process_scratch_entry (t : (_, _, _, _) t) k1 mv = else t.result.removes_received <- t.result.removes_received + 1 let count_output_entry (r : process_result) _k mv = + let mv = ReactiveAllocator.unsafe_from_offheap mv in if ReactiveMaybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 65422df1f50..25459d47cf9 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -19,7 +19,11 @@ val create : output_wave:('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t -> ('k1, 'v1, 'k2, 'v2) t -val push : ('k1, 'v1, 'k2, 'v2) t -> 'k1 -> 'v1 ReactiveMaybe.t -> unit +val push : + ('k1, 'v1, 'k2, 'v2) t -> + 'k1 ReactiveAllocator.offheap -> + 'v1 ReactiveMaybe.t ReactiveAllocator.offheap -> + unit (** Push an entry into the scratch table. *) val process : ('k1, 'v1, 'k2, 'v2) t -> process_result diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index e0b38cfa457..5145a1b8d5a 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -88,8 +88,15 @@ let create ~key_of ~f ~merge ~right_get ~output_wave = in t -let push_left t k v_opt = ReactiveHash.Map.replace t.left_scratch k v_opt -let push_right t k v_opt = ReactiveHash.Map.replace t.right_scratch k v_opt +let push_left t k v_opt = + ReactiveHash.Map.replace t.left_scratch + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v_opt) + +let push_right t k v_opt = + ReactiveHash.Map.replace t.right_scratch + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v_opt) (* Remove one contribution key during remove_left_contributions iteration *) let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = @@ -137,10 +144,14 @@ let recompute_target (t : (_, _, _, _, _, _) t) k3 = ReactivePoolMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; ReactiveHash.Map.replace t.target k3 t.merge_acc; - ReactiveWave.push t.output_wave k3 (ReactiveMaybe.some t.merge_acc)) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k3) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some t.merge_acc))) else ( ReactiveHash.Map.remove t.target k3; - ReactiveWave.push t.output_wave k3 ReactiveMaybe.none) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k3) + ReactiveMaybe.none_offheap) (* Single-pass process + count for left scratch *) let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = @@ -172,6 +183,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = (ReactiveMaybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = + let mv = ReactiveAllocator.unsafe_from_offheap mv in if ReactiveMaybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index 2a268454932..3048238c6b1 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -22,11 +22,17 @@ val create : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t val push_left : - ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k1 -> 'v1 ReactiveMaybe.t -> unit + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> + 'k1 ReactiveAllocator.offheap -> + 'v1 ReactiveMaybe.t ReactiveAllocator.offheap -> + unit (** Push an entry into the left scratch table. *) val push_right : - ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k2 -> 'v2 ReactiveMaybe.t -> unit + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> + 'k2 ReactiveAllocator.offheap -> + 'v2 ReactiveMaybe.t ReactiveAllocator.offheap -> + unit (** Push an entry into the right scratch table. *) val process : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> process_result diff --git a/analysis/reactive/src/ReactiveMaybe.ml b/analysis/reactive/src/ReactiveMaybe.ml index dcc1bca0b63..508e430e091 100644 --- a/analysis/reactive/src/ReactiveMaybe.ml +++ b/analysis/reactive/src/ReactiveMaybe.ml @@ -6,12 +6,21 @@ type 'a t = Obj.t -let sentinel : Obj.t = Obj.repr (ref ()) +let sentinel_words = 257 +let sentinel : Obj.t = Obj.repr (Array.make sentinel_words 0) let none = sentinel +let none_offheap = ReactiveAllocator.to_offheap 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] maybe_int_to_offheap (x : int t) : int t ReactiveAllocator.offheap = + ReactiveAllocator.unsafe_to_offheap x + +let[@inline] maybe_unit_to_offheap (x : unit t) : + unit t ReactiveAllocator.offheap = + ReactiveAllocator.unsafe_to_offheap x + let[@inline] to_option (x : 'a t) : 'a option = if x != sentinel then Some (Obj.obj x) else None diff --git a/analysis/reactive/src/ReactiveMaybe.mli b/analysis/reactive/src/ReactiveMaybe.mli index d94c0e63394..c9b60329545 100644 --- a/analysis/reactive/src/ReactiveMaybe.mli +++ b/analysis/reactive/src/ReactiveMaybe.mli @@ -10,8 +10,20 @@ type 'a t val none : 'a t +(** Unique sentinel representing the absent case. *) + +val none_offheap : 'a t ReactiveAllocator.offheap +(** Off-heap-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 maybe_int_to_offheap : int t -> int t ReactiveAllocator.offheap +(** Safely mark an [int] maybe value as suitable for off-heap storage. *) + +val maybe_unit_to_offheap : unit t -> unit t ReactiveAllocator.offheap +(** Safely mark a [unit] maybe value as suitable for off-heap storage. *) + val to_option : 'a t -> 'a option diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml index ac39592abb2..f9ffb0a34fd 100644 --- a/analysis/reactive/src/ReactiveTable.ml +++ b/analysis/reactive/src/ReactiveTable.ml @@ -14,13 +14,13 @@ let create ~initial_capacity = let t = ReactiveAllocator.Block.create ~capacity:(initial_capacity + data_offset) in - ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.unsafe_to_offheap 0); + ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.int_to_offheap 0); t let destroy = ReactiveAllocator.Block.destroy let clear t = - ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.unsafe_to_offheap 0) + ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.int_to_offheap 0) let ensure_capacity t needed = let old_capacity = capacity t in @@ -47,14 +47,14 @@ let push t value = ensure_capacity t next_len; ReactiveAllocator.Block.set t (len + data_offset) value; ReactiveAllocator.Block.set t length_slot - (ReactiveAllocator.unsafe_to_offheap next_len) + (ReactiveAllocator.int_to_offheap next_len) let pop t = let len = length t in if len = 0 then invalid_arg "ReactiveTable.pop"; let last = ReactiveAllocator.Block.get t (len - 1 + data_offset) in ReactiveAllocator.Block.set t length_slot - (ReactiveAllocator.unsafe_to_offheap (len - 1)); + (ReactiveAllocator.int_to_offheap (len - 1)); last let shrink_to_fit t = diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index 90ba77bf4e1..cc96dcb67e4 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -46,8 +46,15 @@ let create ~merge ~output_wave = }; } -let push_left t k mv = ReactiveHash.Map.replace t.left_scratch k mv -let push_right t k mv = ReactiveHash.Map.replace t.right_scratch k mv +let push_left t k mv = + ReactiveHash.Map.replace t.left_scratch + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap mv) + +let push_right t k mv = + ReactiveHash.Map.replace t.right_scratch + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap mv) (* Module-level helpers for iter_with — avoid closure allocation *) @@ -85,18 +92,26 @@ let recompute_affected_entry t k = t.merge (ReactiveMaybe.unsafe_get lv) (ReactiveMaybe.unsafe_get rv) in ReactiveHash.Map.replace t.target k merged; - ReactiveWave.push t.output_wave k (ReactiveMaybe.some merged)) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some merged))) else let v = ReactiveMaybe.unsafe_get lv in ReactiveHash.Map.replace t.target k v; - ReactiveWave.push t.output_wave k (ReactiveMaybe.some v)) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) else if has_right then ( let v = ReactiveMaybe.unsafe_get rv in ReactiveHash.Map.replace t.target k v; - ReactiveWave.push t.output_wave k (ReactiveMaybe.some v)) + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) else ( ReactiveHash.Map.remove t.target k; - ReactiveWave.push t.output_wave k ReactiveMaybe.none); + ReactiveWave.push t.output_wave + (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMaybe.none_offheap); 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 diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index ecf5824a996..e764793a897 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -19,10 +19,18 @@ val create : ('k, 'v) t (** Create union state with the given merge function and output wave buffer. *) -val push_left : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t -> unit +val push_left : + ('k, 'v) t -> + 'k ReactiveAllocator.offheap -> + 'v ReactiveMaybe.t ReactiveAllocator.offheap -> + unit (** Push an entry into the left scratch table. *) -val push_right : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t -> unit +val push_right : + ('k, 'v) t -> + 'k ReactiveAllocator.offheap -> + 'v ReactiveMaybe.t ReactiveAllocator.offheap -> + unit (** Push an entry into the right scratch table. *) val process : ('k, 'v) t -> process_result diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index fb1dc32eb3a..151339affd6 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -1,31 +1,66 @@ -type ('k, 'v) t = {keys: Obj.t array; vals: Obj.t array; mutable len: int} +type ('k, 'v) t = ReactiveAllocator.Block.t + +let length_slot = 0 +let data_offset = 1 +let entry_width = 2 + +let length t : int = + ReactiveAllocator.unsafe_from_offheap + (ReactiveAllocator.Block.get t length_slot) + +let set_length t len = + ReactiveAllocator.Block.set t length_slot + (ReactiveAllocator.int_to_offheap len) let create ~max_entries = - if max_entries <= 0 then - invalid_arg "ReactiveWave.create: max_entries must be > 0"; - { - keys = Array.make max_entries (Obj.repr ()); - vals = Array.make max_entries (Obj.repr ()); - len = 0; - } - -let clear t = t.len <- 0 - -let push (type k v) (t : (k, v) t) (k : k) (v : v) = - if t.len >= Array.length t.keys then - invalid_arg "ReactiveWave.push: capacity exceeded"; - t.keys.(t.len) <- Obj.repr k; - t.vals.(t.len) <- Obj.repr v; - t.len <- t.len + 1 - -let iter (type k v) (t : (k, v) t) (f : k -> v -> unit) = - for i = 0 to t.len - 1 do - f (Obj.obj t.keys.(i) : k) (Obj.obj t.vals.(i) : v) + if max_entries < 0 then + invalid_arg "ReactiveWave.create: max_entries must be >= 0"; + let t = + ReactiveAllocator.Block.create + ~capacity:(data_offset + (max_entries * entry_width)) + in + set_length t 0; + t + +let clear t = set_length t 0 + +let ensure_capacity t needed = + let current = (ReactiveAllocator.Block.capacity t - data_offset) / entry_width in + if needed > current then ( + let next = ref (max 1 current) in + while !next < needed do + next := !next * 2 + done; + ReactiveAllocator.Block.resize t + ~capacity:(data_offset + (!next * entry_width))) + +let push (type k v) (t : (k, v) t) (k : k ReactiveAllocator.offheap) + (v : v ReactiveAllocator.offheap) = + let len = length t in + ensure_capacity t (len + 1); + let key_slot = data_offset + (len * entry_width) in + ReactiveAllocator.Block.set t key_slot k; + ReactiveAllocator.Block.set t (key_slot + 1) v; + set_length t (len + 1) + +let iter (type k v) (t : (k, v) t) + (f : k ReactiveAllocator.offheap -> v ReactiveAllocator.offheap -> unit) = + let len = length t in + for i = 0 to len - 1 do + let key_slot = data_offset + (i * entry_width) in + f (ReactiveAllocator.Block.get t key_slot) + (ReactiveAllocator.Block.get t (key_slot + 1)) done -let iter_with (type a k v) (t : (k, v) t) (f : a -> k -> v -> unit) (arg : a) = - for i = 0 to t.len - 1 do - f arg (Obj.obj t.keys.(i) : k) (Obj.obj t.vals.(i) : v) +let iter_with (type a k v) (t : (k, v) t) + (f : + a -> k ReactiveAllocator.offheap -> v ReactiveAllocator.offheap -> unit) + (arg : a) = + let len = length t in + for i = 0 to len - 1 do + let key_slot = data_offset + (i * entry_width) in + f arg (ReactiveAllocator.Block.get t key_slot) + (ReactiveAllocator.Block.get t (key_slot + 1)) done -let count t = t.len +let count t = length t diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli index 25f32dbd93f..51c5a0b3414 100644 --- a/analysis/reactive/src/ReactiveWave.mli +++ b/analysis/reactive/src/ReactiveWave.mli @@ -1,11 +1,41 @@ +(** A wave is a growable batch of key/value entries stored in off-heap + allocator-backed storage. Its API is marked with + [ReactiveAllocator.offheap] 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 -> ('k, 'v) t +(** Create an empty wave with an initial capacity hint. The wave grows + automatically if that capacity is exceeded. *) + val clear : ('k, 'v) t -> unit -val push : ('k, 'v) t -> 'k -> 'v -> unit -val iter : ('k, 'v) t -> ('k -> 'v -> unit) -> unit +(** Remove all entries from the wave without releasing its storage. *) + +val push : + ('k, 'v) t -> + 'k ReactiveAllocator.offheap -> + 'v ReactiveAllocator.offheap -> + unit +(** Append one off-heap-marked entry to the wave. Callers are currently + responsible for establishing the off-heap invariant before calling. *) + +val iter : + ('k, 'v) t -> + ( 'k ReactiveAllocator.offheap -> + 'v ReactiveAllocator.offheap -> + unit ) -> + unit -val iter_with : ('k, 'v) t -> ('a -> 'k -> 'v -> unit) -> 'a -> unit +val iter_with : + ('k, 'v) t -> + ( 'a -> + 'k ReactiveAllocator.offheap -> + 'v ReactiveAllocator.offheap -> + 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. *) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index bd5686e78c2..84a1dd623f3 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -7,6 +7,15 @@ open TestHelpers let words_since = AllocMeasure.words_since +let off = ReactiveAllocator.unsafe_to_offheap +let off_int = ReactiveAllocator.int_to_offheap +let off_unit = ReactiveAllocator.unit_to_offheap +let off_maybe_int = ReactiveMaybe.maybe_int_to_offheap +let off_maybe_unit = ReactiveMaybe.maybe_unit_to_offheap + +let unsafe_wave_push wave k v = + ReactiveWave.push wave (off k) (off v) + (* ---- Fixpoint allocation ---- *) let test_fixpoint_alloc_n n = @@ -17,18 +26,18 @@ let test_fixpoint_alloc_n n = (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) let root_snap = ReactiveWave.create ~max_entries:1 in let edge_snap = ReactiveWave.create ~max_entries:n in - ReactiveWave.push root_snap 0 (); + ReactiveWave.push root_snap (off_int 0) (off_unit ()); for i = 0 to n - 2 do - ReactiveWave.push edge_snap i [i + 1] + unsafe_wave_push edge_snap i [i + 1] done; ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; assert (ReactiveFixpoint.current_length state = n); (* Pre-build waves once *) let remove_root = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push remove_root 0 ReactiveMaybe.none; + ReactiveWave.push remove_root (off 0) ReactiveMaybe.none_offheap; let add_root = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push add_root 0 (ReactiveMaybe.some ()); + ReactiveWave.push add_root (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); let no_edges = ReactiveWave.create ~max_entries:1 in (* Warmup *) @@ -72,7 +81,7 @@ let test_flatmap_alloc_n n = (* Populate: n entries *) for i = 0 to n - 1 do - ReactiveFlatMap.push state i (ReactiveMaybe.some i) + ReactiveFlatMap.push state (off_int i) (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n); @@ -80,12 +89,13 @@ let test_flatmap_alloc_n 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 i ReactiveMaybe.none + ReactiveFlatMap.push state (off i) ReactiveMaybe.none_offheap done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = 0); for i = 0 to n - 1 do - ReactiveFlatMap.push state i (ReactiveMaybe.some i) + ReactiveFlatMap.push state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n) @@ -96,11 +106,12 @@ let test_flatmap_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveFlatMap.push state i ReactiveMaybe.none + ReactiveFlatMap.push state (off i) ReactiveMaybe.none_offheap done; ignore (ReactiveFlatMap.process state); for i = 0 to n - 1 do - ReactiveFlatMap.push state i (ReactiveMaybe.some i) + ReactiveFlatMap.push state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveFlatMap.process state) done; @@ -124,7 +135,7 @@ let test_union_alloc_n n = (* Populate: n entries on the left side *) for i = 0 to n - 1 do - ReactiveUnion.push_left state i (ReactiveMaybe.some i) + ReactiveUnion.push_left state (off_int i) (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n); @@ -132,12 +143,13 @@ let test_union_alloc_n 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 i ReactiveMaybe.none + ReactiveUnion.push_left state (off i) ReactiveMaybe.none_offheap done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = 0); for i = 0 to n - 1 do - ReactiveUnion.push_left state i (ReactiveMaybe.some i) + ReactiveUnion.push_left state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n) @@ -148,11 +160,12 @@ let test_union_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveUnion.push_left state i ReactiveMaybe.none + ReactiveUnion.push_left state (off i) ReactiveMaybe.none_offheap done; ignore (ReactiveUnion.process state); for i = 0 to n - 1 do - ReactiveUnion.push_left state i (ReactiveMaybe.some i) + ReactiveUnion.push_left state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveUnion.process state) done; @@ -189,7 +202,7 @@ let test_join_alloc_n n = ReactiveHash.Map.replace right_tbl i (i * 10) done; for i = 0 to n - 1 do - ReactiveJoin.push_left state i (ReactiveMaybe.some i) + ReactiveJoin.push_left state (off_int i) (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n); @@ -197,12 +210,13 @@ let test_join_alloc_n n = (* Warmup: toggle all left entries *) for _ = 1 to 5 do for i = 0 to n - 1 do - ReactiveJoin.push_left state i ReactiveMaybe.none + ReactiveJoin.push_left state (off i) ReactiveMaybe.none_offheap done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = 0); for i = 0 to n - 1 do - ReactiveJoin.push_left state i (ReactiveMaybe.some i) + ReactiveJoin.push_left state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n) @@ -213,11 +227,12 @@ let test_join_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveJoin.push_left state i ReactiveMaybe.none + ReactiveJoin.push_left state (off i) ReactiveMaybe.none_offheap done; ignore (ReactiveJoin.process state); for i = 0 to n - 1 do - ReactiveJoin.push_left state i (ReactiveMaybe.some i) + ReactiveJoin.push_left state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveJoin.process state) done; @@ -262,11 +277,11 @@ let test_reactive_join_alloc_n n = (* Pre-build waves for the hot loop: toggle all left entries *) let remove_wave = ReactiveWave.create ~max_entries:n in for i = 0 to n - 1 do - ReactiveWave.push remove_wave i ReactiveMaybe.none + ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap done; let add_wave = ReactiveWave.create ~max_entries:n in for i = 0 to n - 1 do - ReactiveWave.push add_wave i (ReactiveMaybe.some i) + unsafe_wave_push add_wave i (ReactiveMaybe.some i) done; (* Warmup *) @@ -309,16 +324,20 @@ let test_reactive_fixpoint_alloc_n n = emit_set emit_edges i [i + 1] done; let reachable = Reactive.fixpoint ~name:"reachable" ~init ~edges () in + Printf.printf " [reactive_fixpoint_alloc_n] fixpoint built n=%d\n" n; + flush_all (); (* Add root to populate *) emit_set emit_root 0 (); + Printf.printf " [reactive_fixpoint_alloc_n] root emitted n=%d\n" n; + flush_all (); assert (Reactive.length reachable = n); (* Pre-build waves for the hot loop *) let remove_wave = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push remove_wave 0 ReactiveMaybe.none; + ReactiveWave.push remove_wave (off 0) ReactiveMaybe.none_offheap; let add_wave = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push add_wave 0 (ReactiveMaybe.some ()); + unsafe_wave_push add_wave 0 (ReactiveMaybe.some ()); (* Warmup *) for _ = 1 to 5 do @@ -365,11 +384,11 @@ let test_reactive_union_alloc_n n = (* Pre-build waves: single wave with all n entries *) let remove_wave = ReactiveWave.create ~max_entries:n in for i = 0 to n - 1 do - ReactiveWave.push remove_wave i ReactiveMaybe.none + ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap done; let add_wave = ReactiveWave.create ~max_entries:n in for i = 0 to n - 1 do - ReactiveWave.push add_wave i (ReactiveMaybe.some i) + unsafe_wave_push add_wave i (ReactiveMaybe.some i) done; (* Warmup *) @@ -419,11 +438,11 @@ let test_reactive_flatmap_alloc_n n = (* Pre-build waves *) let remove_wave = ReactiveWave.create ~max_entries:n in for i = 0 to n - 1 do - ReactiveWave.push remove_wave i ReactiveMaybe.none + ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap done; let add_wave = ReactiveWave.create ~max_entries:n in for i = 0 to n - 1 do - ReactiveWave.push add_wave i (ReactiveMaybe.some i) + unsafe_wave_push add_wave i (ReactiveMaybe.some i) done; (* Warmup *) diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index cb0322626aa..3b66471a7cd 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -19,6 +19,8 @@ let track_deltas c = c.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> + let k = ReactiveAllocator.unsafe_from_offheap k in + let mv = ReactiveAllocator.unsafe_from_offheap mv in rev_entries := (k, mv) :: !rev_entries); received := List.rev !rev_entries :: !received); received diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 157b64df71c..e0faa00c10b 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -9,7 +9,7 @@ open Reactive 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) ReactiveWave.t = - ReactiveWave.create ~max_entries:65_536 + ReactiveWave.create ~max_entries:16 let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave @@ -17,21 +17,27 @@ let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave let emit_set emit k v = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w k (ReactiveMaybe.some v); + ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)); emit w (** Emit a single remove entry *) let emit_remove emit k = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w k ReactiveMaybe.none; + ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMaybe.none_offheap; emit w (** Emit a batch of (key, value) set entries *) let emit_sets emit entries = let w = wave () in ReactiveWave.clear w; - List.iter (fun (k, v) -> ReactiveWave.push w k (ReactiveMaybe.some v)) entries; + List.iter + (fun (k, v) -> + ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) + entries; emit w (** Emit a batch of (key, value option) entries — for mixed set/remove batches *) @@ -41,8 +47,12 @@ let emit_batch emit entries = List.iter (fun (k, v_opt) -> match v_opt with - | Some v -> ReactiveWave.push w k (ReactiveMaybe.some v) - | None -> ReactiveWave.push w k ReactiveMaybe.none) + | Some v -> + ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)) + | None -> + ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMaybe.none_offheap) entries; emit w @@ -53,6 +63,8 @@ let subscribe handler t = t.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> + let k = ReactiveAllocator.unsafe_from_offheap k in + let mv = ReactiveAllocator.unsafe_from_offheap mv in rev_entries := (k, mv) :: !rev_entries); handler (List.rev !rev_entries)) From 8d2d323cc7cc55a53daa8bbedce3796f4134e781 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 14:46:24 +0100 Subject: [PATCH 04/54] analysis/reactive: promote fixpoint edge values in tests --- analysis/reactive/src/Reactive.ml | 28 ++-------------------------- analysis/reactive/test/AllocTest.ml | 27 +++++++++++++++------------ 2 files changed, 17 insertions(+), 38 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index bd23339e8f8..00c60c8d7fe 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -877,34 +877,10 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : let init_edges_wave = ReactiveWave.create ~max_entries:(max 1 (edges.length ())) in - Printf.printf - "[Reactive.fixpoint] init existing data name=%s roots=%d edges=%d\n" name - (init.length ()) (edges.length ()); - flush_all (); ReactiveWave.clear init_roots_wave; ReactiveWave.clear init_edges_wave; - let init_root_count = ref 0 in - init.iter (fun k () -> - incr init_root_count; - if !init_root_count <= 5 || !init_root_count mod 100 = 0 then ( - Printf.printf - "[Reactive.fixpoint] init root push name=%s count=%d\n" name - !init_root_count; - flush_all ()); - unsafe_wave_push init_roots_wave k ()); - let init_edge_count = ref 0 in - edges.iter (fun k succs -> - incr init_edge_count; - if !init_edge_count <= 5 || !init_edge_count mod 100 = 0 then ( - Printf.printf - "[Reactive.fixpoint] init edge push name=%s count=%d\n" name - !init_edge_count; - flush_all ()); - unsafe_wave_push init_edges_wave k succs); - Printf.printf - "[Reactive.fixpoint] init existing data loaded name=%s roots=%d edges=%d\n" - name !init_root_count !init_edge_count; - flush_all (); + init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); + edges.iter (fun k succs -> unsafe_wave_push init_edges_wave k succs); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 84a1dd623f3..5f569f796e5 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -19,23 +19,24 @@ let unsafe_wave_push wave k v = (* ---- Fixpoint allocation ---- *) let test_fixpoint_alloc_n n = - let state = - ReactiveFixpoint.create ~max_nodes:(n * 10) ~max_edges:(n * 100) - in + let edge_values = Array.init (max 0 (n - 1)) (fun i -> [i + 1]) in + Gc.full_major (); + let state = ReactiveFixpoint.create ~max_nodes:n ~max_edges:n in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) let root_snap = ReactiveWave.create ~max_entries:1 in let edge_snap = ReactiveWave.create ~max_entries:n in ReactiveWave.push root_snap (off_int 0) (off_unit ()); for i = 0 to n - 2 do - unsafe_wave_push edge_snap i [i + 1] + ReactiveWave.push edge_snap (off_int i) + (ReactiveAllocator.to_offheap (edge_values.(i))) done; ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; assert (ReactiveFixpoint.current_length state = n); (* Pre-build waves once *) let remove_root = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push remove_root (off 0) ReactiveMaybe.none_offheap; + ReactiveWave.push remove_root (off_int 0) ReactiveMaybe.none_offheap; let add_root = ReactiveWave.create ~max_entries:1 in ReactiveWave.push add_root (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); let no_edges = ReactiveWave.create ~max_entries:1 in @@ -316,28 +317,30 @@ let test_reactive_join_alloc () = 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 init, emit_root = Reactive.source ~name:"init" () in let edges, emit_edges = Reactive.source ~name:"edges" () in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) + let edge_wave = ReactiveWave.create ~max_entries:(max 1 (n - 1)) in + ReactiveWave.clear edge_wave; for i = 0 to n - 2 do - emit_set emit_edges i [i + 1] + ReactiveWave.push edge_wave (off_int i) + (ReactiveAllocator.to_offheap (ReactiveMaybe.some edge_values.(i))) done; + emit_edges edge_wave; let reachable = Reactive.fixpoint ~name:"reachable" ~init ~edges () in - Printf.printf " [reactive_fixpoint_alloc_n] fixpoint built n=%d\n" n; - flush_all (); (* Add root to populate *) emit_set emit_root 0 (); - Printf.printf " [reactive_fixpoint_alloc_n] root emitted n=%d\n" n; - flush_all (); assert (Reactive.length reachable = n); (* Pre-build waves for the hot loop *) let remove_wave = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push remove_wave (off 0) ReactiveMaybe.none_offheap; + ReactiveWave.push remove_wave (off_int 0) ReactiveMaybe.none_offheap; let add_wave = ReactiveWave.create ~max_entries:1 in - unsafe_wave_push add_wave 0 (ReactiveMaybe.some ()); + ReactiveWave.push add_wave (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); (* Warmup *) for _ = 1 to 5 do From 9f4e9a1eda60e627a05b7ede1de058d1a0ee5c69 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 15:25:44 +0100 Subject: [PATCH 05/54] analysis/reactive: reorganize reactive node constructors --- analysis/reactive/src/Reactive.ml | 48 +++++-- analysis/reactive/src/Reactive.mli | 118 ++++++++++-------- analysis/reactive/src/ReactiveAllocator.ml | 23 ++-- analysis/reactive/src/ReactiveAllocator.mli | 9 +- .../reactive/src/ReactiveFileCollection.ml | 2 +- .../reactive/src/ReactiveFileCollection.mli | 5 +- analysis/reactive/src/ReactiveFlatMap.mli | 2 +- analysis/reactive/src/ReactiveJoin.mli | 2 +- analysis/reactive/src/ReactiveMaybe.ml | 3 +- analysis/reactive/src/ReactiveMaybe.mli | 1 + analysis/reactive/src/ReactiveUnion.mli | 2 +- analysis/reactive/src/ReactiveWave.ml | 12 +- analysis/reactive/src/ReactiveWave.mli | 12 +- .../reactive/src/reactive_allocator_stubs.c | 19 +++ analysis/reactive/test/AllocTest.ml | 95 +++++++++++--- analysis/reactive/test/BatchTest.ml | 10 +- analysis/reactive/test/FixpointBasicTest.ml | 48 +++---- .../reactive/test/FixpointIncrementalTest.ml | 114 ++++++++--------- analysis/reactive/test/FlatMapTest.ml | 20 +-- analysis/reactive/test/GlitchFreeTest.ml | 47 +++---- analysis/reactive/test/IntegrationTest.ml | 6 +- analysis/reactive/test/JoinTest.ml | 12 +- analysis/reactive/test/TableTest.ml | 26 ++-- analysis/reactive/test/TestHelpers.ml | 15 ++- analysis/reactive/test/UnionTest.ml | 26 ++-- analysis/reactive/test/dune | 2 +- 26 files changed, 409 insertions(+), 270 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 00c60c8d7fe..00aa7d260d1 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -459,6 +459,7 @@ type ('k, 'v) t = { iter: ('k -> 'v -> unit) -> unit; get: 'k -> 'v ReactiveMaybe.t; length: unit -> int; + destroy: unit -> unit; stats: stats; level: int; node: Registry.node_info; @@ -467,12 +468,18 @@ type ('k, 'v) t = { 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 +let todo_destroy name = + Printf.eprintf "TODO: Reactive.destroy for node %s\n%!" name; + assert false + let unsafe_wave_push wave k v = - ReactiveWave.push wave (ReactiveAllocator.unsafe_to_offheap k) + ReactiveWave.push wave + (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap v) let unsafe_wave_map_replace pending k v = @@ -500,7 +507,7 @@ let apply_source_emit (tables : ('k, 'v) source_tables) k mv = ReactiveHash.Map.remove tables.tbl k; ReactiveHash.Map.replace tables.pending k ReactiveMaybe.none) -let source ~name () = +let source_create ~name () = let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.create () in let subscribers = ref [] in let my_stats = create_stats () in @@ -534,6 +541,7 @@ let source ~name () = iter = (fun f -> ReactiveHash.Map.iter f tbl); get = (fun k -> ReactiveHash.Map.find_maybe tbl k); length = (fun () -> ReactiveHash.Map.cardinal tbl); + destroy = (fun () -> ReactiveWave.destroy output_wave); stats = my_stats; level = 0; node = my_info; @@ -555,7 +563,7 @@ let source ~name () = (** {1 FlatMap} *) -let flatMap ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = +let flatmap_create ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = let my_level = src.level + 1 in let merge_fn = match merge with @@ -611,6 +619,7 @@ let flatMap ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = iter = (fun f -> ReactiveFlatMap.iter_target f state); get = (fun k -> ReactiveFlatMap.find_target state k); length = (fun () -> ReactiveFlatMap.target_length state); + destroy = (fun () -> todo_destroy name); stats = my_stats; level = my_level; node = my_info; @@ -618,8 +627,8 @@ let flatMap ~name (src : ('k1, 'v1) t) ~f ?merge () : ('k2, 'v2) t = (** {1 Join} *) -let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () - : ('k3, 'v3) t = +let join_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 @@ -692,6 +701,7 @@ let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () iter = (fun f -> ReactiveJoin.iter_target f state); get = (fun k -> ReactiveJoin.find_target state k); length = (fun () -> ReactiveJoin.target_length state); + destroy = (fun () -> todo_destroy name); stats = my_stats; level = my_level; node = my_info; @@ -699,8 +709,8 @@ let join ~name (left : ('k1, 'v1) t) (right : ('k2, 'v2) t) ~key_of ~f ?merge () (** {1 Union} *) -let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t - = +let union_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 @@ -771,6 +781,7 @@ let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t iter = (fun f -> ReactiveUnion.iter_target f state); get = (fun k -> ReactiveUnion.find_target state k); length = (fun () -> ReactiveUnion.target_length state); + destroy = (fun () -> todo_destroy name); stats = my_stats; level = my_level; node = my_info; @@ -778,7 +789,7 @@ let union ~name (left : ('k, 'v) t) (right : ('k, 'v) t) ?merge () : ('k, 'v) t (** {1 Fixpoint} *) -let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : +let fixpoint_create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = let my_level = max init.level edges.level + 1 in let int_env_or name default = @@ -890,6 +901,7 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : iter = (fun f -> ReactiveFixpoint.iter_current state f); get = (fun k -> ReactiveFixpoint.get_current state k); length = (fun () -> ReactiveFixpoint.current_length state); + destroy = (fun () -> todo_destroy name); stats = my_stats; level = my_level; node = my_info; @@ -897,6 +909,26 @@ let fixpoint ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : (** {1 Utilities} *) +module Source = struct + let create = source_create +end + +module FlatMap = struct + let create = flatmap_create +end + +module Join = struct + let create = join_create +end + +module Union = struct + let create = union_create +end + +module Fixpoint = struct + let create = fixpoint_create +end + let to_mermaid () = Registry.to_mermaid () let print_stats () = Registry.print_stats () let set_debug = set_debug diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index df1da0cc674..33589a6dece 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -75,6 +75,7 @@ type ('k, 'v) t = { iter: ('k -> 'v -> unit) -> unit; get: 'k -> 'v ReactiveMaybe.t; length: unit -> int; + destroy: unit -> unit; stats: stats; level: int; node: Registry.node_info; @@ -84,68 +85,79 @@ type ('k, 'v) t = { val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit val get : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.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 ReactiveMaybe.t) ReactiveWave.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 [ReactiveMaybe.some v] for set - or [ReactiveMaybe.none] for remove. - Emitting triggers propagation through the pipeline. *) +module Source : sig + val create : + name:string -> + unit -> + ('k, 'v) t * (('k, 'v ReactiveMaybe.t) ReactiveWave.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 [ReactiveMaybe.some v] for set + or [ReactiveMaybe.none] for remove. + Emitting triggers propagation through the pipeline. *) +end (** {1 Combinators} *) -val flatMap : - name:string -> - ('k1, 'v1) t -> - f:('k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> - ?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 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> - ?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 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> + ?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. *) +end + +module Join : sig + val create : + name:string -> + ('k1, 'v1) t -> + ('k2, 'v2) t -> + key_of:('k1 -> 'v1 -> 'k2) -> + f:('k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> + ?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. *) +end + +module Union : sig + val create : + 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. *) +end + +module Fixpoint : sig + val create : + 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 *) +end (** {1 Utilities} *) diff --git a/analysis/reactive/src/ReactiveAllocator.ml b/analysis/reactive/src/ReactiveAllocator.ml index 6c529a54d02..929aae8d3d6 100644 --- a/analysis/reactive/src/ReactiveAllocator.ml +++ b/analysis/reactive/src/ReactiveAllocator.ml @@ -1,19 +1,20 @@ type 'a offheap = 'a -external slot_size_bytes_unsafe : unit -> int = - "caml_reactive_allocator_slot_size_bytes" +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" +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" +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 check_non_negative name n = if n < 0 then invalid_arg name let slot_size_bytes = slot_size_bytes_unsafe () let unsafe_to_offheap x = x @@ -39,12 +40,12 @@ module Block = struct external unsafe_get : t -> int -> 'a offheap = "caml_reactive_allocator_get" [@@noalloc] - external unsafe_set : t -> int -> 'a offheap -> unit = - "caml_reactive_allocator_set" + external unsafe_set : t -> int -> 'a offheap -> unit + = "caml_reactive_allocator_set" [@@noalloc] - external blit_unsafe : - t -> int -> t -> int -> int -> unit = "caml_reactive_allocator_blit" + external blit_unsafe : t -> int -> t -> int -> int -> unit + = "caml_reactive_allocator_blit" [@@noalloc] let create ~capacity = diff --git a/analysis/reactive/src/ReactiveAllocator.mli b/analysis/reactive/src/ReactiveAllocator.mli index e3c027ccab2..4c41107ed7a 100644 --- a/analysis/reactive/src/ReactiveAllocator.mli +++ b/analysis/reactive/src/ReactiveAllocator.mli @@ -60,8 +60,7 @@ module Block : sig val set : t -> int -> 'a offheap -> unit (** Write a slot. *) - val blit : - src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit + val blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit (** Copy a range of raw value slots between blocks. *) end @@ -74,6 +73,12 @@ val live_block_count : unit -> int 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 off-heap storage diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index 49047c57030..321046f0d86 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -31,7 +31,7 @@ type ('raw, 'v) t = { (** 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 + let collection, emit = Reactive.Source.create ~name:"file_collection" () in let scratch_wave = ReactiveWave.create ~max_entries:16 in {internal; collection; emit; scratch_wave} diff --git a/analysis/reactive/src/ReactiveFileCollection.mli b/analysis/reactive/src/ReactiveFileCollection.mli index e50c6618284..f4d1b301e62 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/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 25459d47cf9..9ccf8313453 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -1,6 +1,6 @@ (** Zero-allocation (steady-state) flatMap state and processing logic. - This module is used by {!Reactive.flatMap}. *) + This module is used by {!Reactive.FlatMap.create}. *) type ('k1, 'v1, 'k2, 'v2) t diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index 3048238c6b1..4862da72593 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -1,6 +1,6 @@ (** Zero-allocation (steady-state) join state and processing logic. - This module is used by {!Reactive.join}. *) + This module is used by {!Reactive.Join.create}. *) type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t diff --git a/analysis/reactive/src/ReactiveMaybe.ml b/analysis/reactive/src/ReactiveMaybe.ml index 508e430e091..5b17b977a9f 100644 --- a/analysis/reactive/src/ReactiveMaybe.ml +++ b/analysis/reactive/src/ReactiveMaybe.ml @@ -15,7 +15,8 @@ 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] maybe_int_to_offheap (x : int t) : int t ReactiveAllocator.offheap = +let[@inline] maybe_int_to_offheap (x : int t) : int t ReactiveAllocator.offheap + = ReactiveAllocator.unsafe_to_offheap x let[@inline] maybe_unit_to_offheap (x : unit t) : diff --git a/analysis/reactive/src/ReactiveMaybe.mli b/analysis/reactive/src/ReactiveMaybe.mli index c9b60329545..b2451a0eb99 100644 --- a/analysis/reactive/src/ReactiveMaybe.mli +++ b/analysis/reactive/src/ReactiveMaybe.mli @@ -20,6 +20,7 @@ val some : 'a -> 'a t val is_none : 'a t -> bool val is_some : 'a t -> bool val unsafe_get : 'a t -> 'a + val maybe_int_to_offheap : int t -> int t ReactiveAllocator.offheap (** Safely mark an [int] maybe value as suitable for off-heap storage. *) diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index e764793a897..c3b46ecf5c8 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -1,6 +1,6 @@ (** Zero-allocation union state and processing logic. - This is a private module used by {!Reactive.union}. *) + This is a private module used by {!Reactive.Union.create}. *) type ('k, 'v) t diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index 151339affd6..7d6317f383b 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -24,8 +24,12 @@ let create ~max_entries = let clear t = set_length t 0 +let destroy t = ReactiveAllocator.Block.destroy t + let ensure_capacity t needed = - let current = (ReactiveAllocator.Block.capacity t - data_offset) / entry_width in + let current = + (ReactiveAllocator.Block.capacity t - data_offset) / entry_width + in if needed > current then ( let next = ref (max 1 current) in while !next < needed do @@ -48,7 +52,8 @@ let iter (type k v) (t : (k, v) t) let len = length t in for i = 0 to len - 1 do let key_slot = data_offset + (i * entry_width) in - f (ReactiveAllocator.Block.get t key_slot) + f + (ReactiveAllocator.Block.get t key_slot) (ReactiveAllocator.Block.get t (key_slot + 1)) done @@ -59,7 +64,8 @@ let iter_with (type a k v) (t : (k, v) t) let len = length t in for i = 0 to len - 1 do let key_slot = data_offset + (i * entry_width) in - f arg (ReactiveAllocator.Block.get t key_slot) + f arg + (ReactiveAllocator.Block.get t key_slot) (ReactiveAllocator.Block.get t (key_slot + 1)) done diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli index 51c5a0b3414..cc41dfe896f 100644 --- a/analysis/reactive/src/ReactiveWave.mli +++ b/analysis/reactive/src/ReactiveWave.mli @@ -13,6 +13,9 @@ val create : max_entries:int -> ('k, 'v) t 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 off-heap storage. The wave must not be used after this. *) + val push : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> @@ -23,17 +26,12 @@ val push : val iter : ('k, 'v) t -> - ( 'k ReactiveAllocator.offheap -> - 'v ReactiveAllocator.offheap -> - unit ) -> + ('k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> unit val iter_with : ('k, 'v) t -> - ( 'a -> - 'k ReactiveAllocator.offheap -> - 'v ReactiveAllocator.offheap -> - unit ) -> + ('a -> 'k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> 'a -> unit (** [iter_with t f arg] calls [f arg k v] for each entry. diff --git a/analysis/reactive/src/reactive_allocator_stubs.c b/analysis/reactive/src/reactive_allocator_stubs.c index d8dd89b054d..fa44418a9a8 100644 --- a/analysis/reactive/src/reactive_allocator_stubs.c +++ b/analysis/reactive/src/reactive_allocator_stubs.c @@ -135,6 +135,25 @@ value caml_reactive_allocator_live_block_capacity_slots(value 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); diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 5f569f796e5..bba5193a13f 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -13,8 +13,25 @@ let off_unit = ReactiveAllocator.unit_to_offheap let off_maybe_int = ReactiveMaybe.maybe_int_to_offheap let off_maybe_unit = ReactiveMaybe.maybe_unit_to_offheap -let unsafe_wave_push wave k v = - ReactiveWave.push wave (off k) (off v) +let unsafe_wave_push wave k v = ReactiveWave.push wave (off k) (off v) + +let print_offheap_usage () = + let blocks = ReactiveAllocator.live_block_count () in + let slots = ReactiveAllocator.live_block_capacity_slots () in + let bytes = slots * ReactiveAllocator.slot_size_bytes in + Printf.printf " offheap: blocks=%d slots=%d bytes=%d\n" blocks slots bytes + +let reset_offheap_state () = + Reactive.reset (); + ReactiveAllocator.reset (); + assert (ReactiveAllocator.live_block_count () = 0); + assert (ReactiveAllocator.live_block_capacity_slots () = 0) + +let print_offheap_snapshot label = + let blocks = ReactiveAllocator.live_block_count () in + let slots = ReactiveAllocator.live_block_capacity_slots () in + let bytes = slots * ReactiveAllocator.slot_size_bytes in + Printf.printf " %s: blocks=%d slots=%d bytes=%d\n" label blocks slots bytes (* ---- Fixpoint allocation ---- *) @@ -29,7 +46,7 @@ let test_fixpoint_alloc_n n = ReactiveWave.push root_snap (off_int 0) (off_unit ()); for i = 0 to n - 2 do ReactiveWave.push edge_snap (off_int i) - (ReactiveAllocator.to_offheap (edge_values.(i))) + (ReactiveAllocator.to_offheap edge_values.(i)) done; ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; assert (ReactiveFixpoint.current_length state = n); @@ -38,7 +55,8 @@ let test_fixpoint_alloc_n n = let remove_root = ReactiveWave.create ~max_entries:1 in ReactiveWave.push remove_root (off_int 0) ReactiveMaybe.none_offheap; let add_root = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push add_root (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); + ReactiveWave.push add_root (off_int 0) + (off_maybe_unit (ReactiveMaybe.some ())); let no_edges = ReactiveWave.create ~max_entries:1 in (* Warmup *) @@ -61,12 +79,14 @@ let test_fixpoint_alloc_n n = words_since () / iters let test_fixpoint_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); Printf.printf "PASSED\n\n" (* ---- FlatMap allocation ---- *) @@ -82,7 +102,8 @@ let test_flatmap_alloc_n n = (* Populate: n entries *) for i = 0 to n - 1 do - ReactiveFlatMap.push state (off_int i) (off_maybe_int (ReactiveMaybe.some i)) + ReactiveFlatMap.push state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n); @@ -120,12 +141,14 @@ let test_flatmap_alloc_n n = words_since () / iters let test_flatmap_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); Printf.printf "PASSED\n\n" (* ---- Union allocation ---- *) @@ -136,7 +159,8 @@ let test_union_alloc_n n = (* Populate: n entries on the left side *) for i = 0 to n - 1 do - ReactiveUnion.push_left state (off_int i) (off_maybe_int (ReactiveMaybe.some i)) + ReactiveUnion.push_left state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n); @@ -174,12 +198,14 @@ let test_union_alloc_n n = words_since () / iters let test_union_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); Printf.printf "PASSED\n\n" (* ---- Join allocation ---- *) @@ -203,7 +229,8 @@ let test_join_alloc_n n = ReactiveHash.Map.replace right_tbl i (i * 10) done; for i = 0 to n - 1 do - ReactiveJoin.push_left state (off_int i) (off_maybe_int (ReactiveMaybe.some i)) + ReactiveJoin.push_left state (off_int i) + (off_maybe_int (ReactiveMaybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n); @@ -241,24 +268,26 @@ let test_join_alloc_n n = words_since () / iters let test_join_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); 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 ~name:"left" () in - let right, emit_right = Reactive.source ~name:"right" () in + 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 ~name:"joined" left right + Reactive.Join.create ~name:"joined" left right ~key_of:(fun k _v -> k) ~f:(fun k v right_mb emit -> if ReactiveMaybe.is_some right_mb then @@ -305,12 +334,14 @@ let test_reactive_join_alloc_n n = words_since () / iters let test_reactive_join_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); Printf.printf "PASSED\n\n" (* ---- Reactive.fixpoint end-to-end allocation ---- *) @@ -319,8 +350,8 @@ 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 init, emit_root = Reactive.source ~name:"init" () in - let edges, emit_edges = Reactive.source ~name:"edges" () 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 = ReactiveWave.create ~max_entries:(max 1 (n - 1)) in @@ -330,7 +361,7 @@ let test_reactive_fixpoint_alloc_n n = (ReactiveAllocator.to_offheap (ReactiveMaybe.some edge_values.(i))) done; emit_edges edge_wave; - let reachable = Reactive.fixpoint ~name:"reachable" ~init ~edges () in + let reachable = Reactive.Fixpoint.create ~name:"reachable" ~init ~edges () in (* Add root to populate *) emit_set emit_root 0 (); @@ -340,7 +371,8 @@ let test_reactive_fixpoint_alloc_n n = let remove_wave = ReactiveWave.create ~max_entries:1 in ReactiveWave.push remove_wave (off_int 0) ReactiveMaybe.none_offheap; let add_wave = ReactiveWave.create ~max_entries:1 in - ReactiveWave.push add_wave (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); + ReactiveWave.push add_wave (off_int 0) + (off_maybe_unit (ReactiveMaybe.some ())); (* Warmup *) for _ = 1 to 5 do @@ -361,22 +393,28 @@ let test_reactive_fixpoint_alloc_n n = words_since () / iters let test_reactive_fixpoint_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); 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 ~name:"left" () in - let right, emit_right = Reactive.source ~name:"right" () in + print_offheap_snapshot "before sources"; + let left, emit_left = Reactive.Source.create ~name:"left" () in + print_offheap_snapshot "after left source"; + let right, emit_right = Reactive.Source.create ~name:"right" () in + print_offheap_snapshot "after right source"; - let merged = Reactive.union ~name:"merged" left right () in + let merged = Reactive.Union.create ~name:"merged" left right () in + print_offheap_snapshot "after union"; (* Populate: n entries on the left side *) for i = 0 to n - 1 do @@ -411,25 +449,32 @@ let test_reactive_union_alloc_n n = emit_left add_wave done; assert (Reactive.length merged = n); - words_since () / iters + let words = words_since () / iters in + ReactiveWave.destroy remove_wave; + ReactiveWave.destroy add_wave; + Reactive.destroy left; + Reactive.destroy right; + words let test_reactive_union_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); 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 ~name:"src" () in + let src, emit_src = Reactive.Source.create ~name:"src" () in let derived = - Reactive.flatMap ~name:"derived" src ~f:(fun k v emit -> emit k v) () + Reactive.FlatMap.create ~name:"derived" src ~f:(fun k v emit -> emit k v) () in (* Populate: n entries *) @@ -467,12 +512,14 @@ let test_reactive_flatmap_alloc_n n = words_since () / iters let test_reactive_flatmap_alloc () = + reset_offheap_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) [10; 100; 1000]; + print_offheap_usage (); Printf.printf "PASSED\n\n" (* ---- PoolMapSet allocation ---- *) @@ -487,6 +534,7 @@ let count_pool_empty_sets pms = s let test_pool_map_set_pattern_drain_key_churn () = + reset_offheap_state (); Printf.printf "=== Test: PoolMapSet pattern (drain_key churn) ===\n"; let n = 100 in let iters = 100 in @@ -519,9 +567,11 @@ let test_pool_map_set_pattern_drain_key_churn () = assert (ReactivePoolMapSet.cardinal pms = n); assert (st.empty = 0); assert (miss_delta = 0); + print_offheap_usage (); Printf.printf "PASSED\n\n" let test_pool_map_set_pattern_remove_recycle_churn () = + reset_offheap_state (); Printf.printf "=== Test: PoolMapSet pattern (remove_from_set_and_recycle_if_empty churn) \ ===\n"; @@ -558,6 +608,7 @@ let test_pool_map_set_pattern_remove_recycle_churn () = assert (ReactivePoolMapSet.cardinal pms = n); assert (st.empty = 0); assert (miss_delta = 0); + print_offheap_usage (); Printf.printf "PASSED\n\n" (* ---- PoolMapMap allocation ---- *) @@ -573,6 +624,7 @@ let count_empty_inner_maps pmm ~start ~count = s let test_pool_map_map_pattern_drain_outer_churn () = + reset_offheap_state (); Printf.printf "=== Test: PoolMapMap pattern (drain_outer churn) ===\n"; let n = 100 in let iters = 100 in @@ -606,9 +658,11 @@ let test_pool_map_map_pattern_drain_outer_churn () = assert (ReactivePoolMapMap.outer_cardinal pmm = n); assert (st.empty = 0); assert (miss_delta = 0); + print_offheap_usage (); Printf.printf "PASSED\n\n" let test_pool_map_map_pattern_remove_recycle_churn () = + reset_offheap_state (); Printf.printf "=== Test: PoolMapMap pattern (remove_from_inner_and_recycle_if_empty \ churn) ===\n"; @@ -646,6 +700,7 @@ let test_pool_map_map_pattern_remove_recycle_churn () = assert (ReactivePoolMapMap.outer_cardinal pmm = n); assert (st.empty = 0); assert (miss_delta = 0); + print_offheap_usage (); Printf.printf "PASSED\n\n" let run_all () = diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 5675ea87bb2..8cdd8093c95 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -7,9 +7,9 @@ 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 + FlatMap.create ~name:"derived" source ~f:(fun k v emit -> emit (k ^ "_derived") (v * 2)) () in @@ -41,10 +41,10 @@ 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 diff --git a/analysis/reactive/test/FixpointBasicTest.ml b/analysis/reactive/test/FixpointBasicTest.ml index be4011738a6..4af0db689d4 100644 --- a/analysis/reactive/test/FixpointBasicTest.ml +++ b/analysis/reactive/test/FixpointBasicTest.ml @@ -7,8 +7,8 @@ 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_set emit_edges 1 [2; 3]; @@ -16,7 +16,7 @@ let test_fixpoint () = emit_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); @@ -56,14 +56,14 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); @@ -79,14 +79,14 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "c" ["d"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); emit_set emit_init "c" (); @@ -103,15 +103,15 @@ 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_set emit_edges "a" ["b"; "c"]; emit_set emit_edges "b" ["d"]; emit_set emit_edges "c" ["d"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); @@ -123,15 +123,15 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "b" ["c"]; emit_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); @@ -146,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_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); @@ -161,13 +161,13 @@ 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_set emit_edges "a" ["a"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); @@ -181,15 +181,15 @@ 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 + let init, emit_init = Source.create ~name:"init" () in emit_set emit_init "root" (); - let edges, emit_edges = source ~name:"edges" () in + let edges, emit_edges = Source.create ~name:"edges" () in emit_set emit_edges "root" ["a"; "b"]; emit_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); diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/FixpointIncrementalTest.ml index 428393533eb..bee3883e8fa 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -7,14 +7,14 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "c" ["d"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); assert (length fp = 2); @@ -49,14 +49,14 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); assert (length fp = 3); @@ -83,10 +83,10 @@ 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_set emit_init "a" (); assert (length fp = 1); @@ -114,14 +114,14 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "b" ["c"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); assert (length fp = 3); @@ -151,15 +151,15 @@ 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_set emit_edges "a" ["b"]; emit_set emit_edges "b" ["c"]; emit_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); assert (length fp = 3); @@ -191,15 +191,15 @@ 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_set emit_edges "a" ["b"; "c"]; emit_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "a" (); assert (length fp = 3); @@ -228,13 +228,13 @@ 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_set emit_edges 1 [2; 3]; emit_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 @@ -273,10 +273,10 @@ let test_fixpoint_remove_spurious_root () = 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 @@ -346,14 +346,14 @@ 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_set emit_edges "a" ["b"]; emit_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 @@ -399,10 +399,10 @@ 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 @@ -455,14 +455,14 @@ let test_fixpoint_remove_edge_entry_rederivation () = reset (); 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_set emit_edges "a" ["c"]; emit_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 @@ -508,10 +508,10 @@ 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 @@ -566,8 +566,8 @@ let test_fixpoint_remove_edge_entry_needs_rederivation () = Printf.printf "=== 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_set emit_edges "r" ["a"; "b"]; @@ -576,7 +576,7 @@ let test_fixpoint_remove_edge_entry_needs_rederivation () = emit_set emit_edges "c" ["x"]; emit_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_set emit_init "r" (); @@ -610,8 +610,8 @@ let test_fixpoint_remove_base_needs_rederivation () = Printf.printf "=== 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_set emit_edges "r1" ["a"]; @@ -621,7 +621,7 @@ let test_fixpoint_remove_base_needs_rederivation () = emit_set emit_edges "c" ["x"]; emit_set emit_edges "x" ["y"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "r1" (); emit_set emit_init "r2" (); @@ -652,8 +652,8 @@ 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_set emit_edges "r" ["a"; "b"]; @@ -661,7 +661,7 @@ let test_fixpoint_batch_overlapping_deletions () = emit_set emit_edges "b" ["x"]; emit_set emit_edges "x" ["y"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); assert (get_opt fp "x" = Some ()); @@ -695,15 +695,15 @@ 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_set emit_edges "r" ["a"; "c"]; emit_set emit_edges "a" ["x"]; emit_set emit_edges "c" []; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); assert (get_opt fp "x" = Some ()); @@ -739,8 +739,8 @@ 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_set emit_edges "r" ["a"; "b"; "c"]; @@ -748,7 +748,7 @@ let test_fixpoint_fanin_single_predecessor_removed () = emit_set emit_edges "b" ["z"]; emit_set emit_edges "c" ["z"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); assert (get_opt fp "z" = Some ()); @@ -779,8 +779,8 @@ 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_set emit_edges "r1" ["b"]; @@ -788,7 +788,7 @@ let test_fixpoint_cycle_alternative_external_support () = emit_set emit_edges "b" ["c"]; emit_set emit_edges "c" ["b"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "r1" (); emit_set emit_init "r2" (); @@ -833,8 +833,8 @@ 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), @@ -843,7 +843,7 @@ let test_fixpoint_remove_then_readd_via_expansion_same_wave () = emit_set emit_edges "s" ["x"]; emit_set emit_edges "y" ["x"]; - let fp = fixpoint ~name:"fp" ~init ~edges () in + let fp = Fixpoint.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); assert (get_opt fp "x" = Some ()); diff --git a/analysis/reactive/test/FlatMapTest.ml b/analysis/reactive/test/FlatMapTest.ml index c1e3175cc95..1dfc874d7cd 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/FlatMapTest.ml @@ -8,11 +8,11 @@ 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 + FlatMap.create ~name:"derived" source ~f:(fun key value emit -> emit (key * 10) value; emit ((key * 10) + 1) value; @@ -54,11 +54,11 @@ 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 + FlatMap.create ~name:"derived" source ~f:(fun _key values emit -> emit 0 values) (* all contribute to key 0 *) ~merge:IntSet.union () in @@ -91,11 +91,11 @@ 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 + FlatMap.create ~name:"items" source ~f:(fun path items emit -> List.iteri (fun i item -> emit (Printf.sprintf "%s:%d" path i) item) @@ -105,7 +105,7 @@ let test_composition () = (* Second flatMap: item -> chars *) let chars = - flatMap ~name:"chars" items + FlatMap.create ~name:"chars" items ~f:(fun key value emit -> String.iteri (fun i c -> emit (Printf.sprintf "%s:%d" key i) c) value) () @@ -141,7 +141,7 @@ 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 + let source, emit = Source.create ~name:"source" () in emit_set emit 1 "a"; emit_set emit 2 "b"; @@ -149,7 +149,9 @@ let test_flatmap_on_existing_data () = (* Create flatMap AFTER source has data *) let derived = - flatMap ~name:"derived" source ~f:(fun k v emit -> emit (k * 10) v) () + FlatMap.create ~name:"derived" source + ~f:(fun k v emit -> emit (k * 10) v) + () in (* Check derived has existing data *) diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index 3b66471a7cd..ed05440bfad 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -45,24 +45,24 @@ 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 + FlatMap.create ~name:"refs" src ~f:(fun _file (data : file_data) emit -> List.iter (fun (k, v) -> emit k v) data.refs) () in let decls = - flatMap ~name:"decls" src + FlatMap.create ~name:"decls" src ~f:(fun _file (data : file_data) emit -> List.iter (fun pos -> emit pos ()) 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_mb emit -> if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) @@ -91,11 +91,11 @@ 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 + FlatMap.create ~name:"refs1" src ~f:(fun _file (data : file_data) emit -> List.iter (fun (k, v) -> if String.length k > 0 && k.[0] = 'D' then emit k v) @@ -105,7 +105,7 @@ let test_multi_level_union () = (* intermediate: level 1 *) let intermediate = - flatMap ~name:"intermediate" src + FlatMap.create ~name:"intermediate" src ~f:(fun _file (data : file_data) emit -> List.iter (fun (k, v) -> if String.length k > 0 && k.[0] = 'I' then emit k v) @@ -115,23 +115,23 @@ let test_multi_level_union () = (* refs2: level 2 *) let refs2 = - flatMap ~name:"refs2" intermediate ~f:(fun k v emit -> emit k v) () + FlatMap.create ~name:"refs2" intermediate ~f:(fun k v emit -> emit k v) () in (* decls: level 1 *) let decls = - flatMap ~name:"decls" src + FlatMap.create ~name:"decls" src ~f:(fun _file (data : file_data) emit -> List.iter (fun pos -> emit pos ()) 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_mb emit -> if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) @@ -157,11 +157,11 @@ 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 + FlatMap.create ~name:"decls" src ~f:(fun _file (data : full_file_data) emit -> List.iter (fun pos -> emit pos ()) data.full_decls) () @@ -169,7 +169,7 @@ let test_real_pipeline_simulation () = (* merged_value_refs: level 1 *) let merged_value_refs = - flatMap ~name:"merged_value_refs" src + FlatMap.create ~name:"merged_value_refs" src ~f:(fun _file (data : full_file_data) emit -> List.iter (fun (k, v) -> emit k v) data.value_refs) () @@ -177,7 +177,7 @@ let test_real_pipeline_simulation () = (* exception_refs_raw: level 1 *) let exception_refs_raw = - flatMap ~name:"exception_refs_raw" src + FlatMap.create ~name:"exception_refs_raw" src ~f:(fun _file (data : full_file_data) emit -> List.iter (fun (k, v) -> emit k v) data.exception_refs) () @@ -185,7 +185,7 @@ let test_real_pipeline_simulation () = (* exception_decls: level 2 *) let exception_decls = - flatMap ~name:"exception_decls" decls + FlatMap.create ~name:"exception_decls" decls ~f:(fun pos () emit -> if String.length pos > 0 && pos.[0] = 'E' then emit pos ()) () @@ -193,7 +193,8 @@ let test_real_pipeline_simulation () = (* 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_mb emit -> if ReactiveMaybe.is_some decl_mb then emit path loc) @@ -202,19 +203,19 @@ let test_real_pipeline_simulation () = (* resolved_refs_from: level 4 *) let resolved_refs_from = - flatMap ~name:"resolved_refs_from" resolved_exception_refs + FlatMap.create ~name:"resolved_refs_from" resolved_exception_refs ~f:(fun posTo posFrom emit -> emit 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_mb emit -> if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) @@ -242,11 +243,11 @@ 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_mb emit -> if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/IntegrationTest.ml index fafdcb1dc67..76fe6f871da 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -8,14 +8,14 @@ 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 + FlatMap.create ~name:"word_counts" files ~f:(fun _path counts emit -> StringMap.iter (fun k v -> emit k v) counts) (* Each file contributes its word counts *) ~merge:( + ) (* Sum counts from multiple files *) @@ -24,7 +24,7 @@ let test_file_collection () = (* Second flatMap: filter to words with count >= 2 *) let frequent_words = - flatMap ~name:"frequent_words" word_counts + FlatMap.create ~name:"frequent_words" word_counts ~f:(fun word count emit -> if count >= 2 then emit word count) () in diff --git a/analysis/reactive/test/JoinTest.ml b/analysis/reactive/test/JoinTest.ml index ed38cc8f408..d5962d2201f 100644 --- a/analysis/reactive/test/JoinTest.ml +++ b/analysis/reactive/test/JoinTest.ml @@ -8,14 +8,14 @@ let test_join () = 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_mb emit -> if ReactiveMaybe.is_some decl_pos_mb then @@ -76,12 +76,12 @@ 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_mb emit -> if ReactiveMaybe.is_some value_mb then diff --git a/analysis/reactive/test/TableTest.ml b/analysis/reactive/test/TableTest.ml index 0646f2a9eb1..2d7bdec9dcb 100644 --- a/analysis/reactive/test/TableTest.ml +++ b/analysis/reactive/test/TableTest.ml @@ -6,7 +6,9 @@ let test_table_promoted_wave_lifecycle () = let count = 128 in let width = 48 in let initial_live_blocks = ReactiveAllocator.live_block_count () in - let initial_live_block_slots = ReactiveAllocator.live_block_capacity_slots () in + let initial_live_block_slots = + ReactiveAllocator.live_block_capacity_slots () + in Gc.full_major (); ignore (AllocMeasure.words_since ()); let t = ReactiveTable.create ~initial_capacity:1 in @@ -42,8 +44,7 @@ let test_table_promoted_wave_lifecycle () = done; assert (ReactiveTable.length t = count); assert (ReactiveTable.capacity t >= ReactiveTable.length t); - ReactiveTable.set t 0 - (ReactiveAllocator.to_offheap fresh.(count - 1)); + ReactiveTable.set t 0 (ReactiveAllocator.to_offheap fresh.(count - 1)); assert ( ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t 0) == fresh.(count - 1)); @@ -109,7 +110,8 @@ let test_table_unsafe_minor_heap_demo () = Gc.compact () done; Printf.printf - "About to validate %d minor-heap values stored off-heap. This is unsafe and may return garbage or crash.\n" + "About to validate %d minor-heap values stored off-heap. This is unsafe \ + and may return garbage or crash.\n" count; let mismatches = ref 0 in let samples = ref [] in @@ -126,23 +128,19 @@ let test_table_unsafe_minor_heap_demo () = if not ok then ( incr mismatches; if List.length !samples < 8 then - let observed_len = - try Bytes.length recovered with _ -> -1 - in - let observed_first = - try Bytes.get recovered 0 with _ -> '?' - in + let observed_len = try Bytes.length recovered with _ -> -1 in + let observed_first = try Bytes.get recovered 0 with _ -> '?' in samples := - Printf.sprintf - "slot=%d expected=%c len=%d first=%c" - i expected observed_len observed_first + Printf.sprintf "slot=%d expected=%c len=%d first=%c" i expected + observed_len observed_first :: !samples) done; Printf.printf "Observed mismatches: %d/%d\n" !mismatches count; List.iter (fun s -> Printf.printf "%s\n" s) (List.rev !samples); ReactiveTable.destroy t; Printf.printf - "UNSAFE DEMO COMPLETED (result is not trustworthy; crash/corruption would also be expected)\n\n" + "UNSAFE DEMO COMPLETED (result is not trustworthy; crash/corruption \ + would also be expected)\n\n" let run_all () = test_table_promoted_wave_lifecycle (); diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index e0faa00c10b..2ebd3fd9589 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -17,7 +17,8 @@ let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave let emit_set emit k v = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)); emit w @@ -25,7 +26,8 @@ let emit_set emit k v = let emit_remove emit k = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) ReactiveMaybe.none_offheap; emit w @@ -35,7 +37,8 @@ let emit_sets emit entries = ReactiveWave.clear w; List.iter (fun (k, v) -> - ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) entries; emit w @@ -48,10 +51,12 @@ let emit_batch emit entries = (fun (k, v_opt) -> match v_opt with | Some v -> - ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)) | None -> - ReactiveWave.push w (ReactiveAllocator.unsafe_to_offheap k) + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) ReactiveMaybe.none_offheap) entries; emit w diff --git a/analysis/reactive/test/UnionTest.ml b/analysis/reactive/test/UnionTest.ml index ea9851ecae2..5bd2f193055 100644 --- a/analysis/reactive/test/UnionTest.ml +++ b/analysis/reactive/test/UnionTest.ml @@ -8,13 +8,13 @@ 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); @@ -63,13 +63,15 @@ 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:IntSet.union () + in (* Add to left: key "x" -> {1, 2} *) emit_set emit_left "x" (IntSet.of_list [1; 2]); @@ -106,17 +108,17 @@ 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 + 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 + let right, emit_right = Source.create ~name:"right" () in emit_set emit_right 2 "B"; (* Overlaps with left *) 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); @@ -134,14 +136,14 @@ let test_union_existing_data_with_non_idempotent_merge () = Printf.printf "=== Test: union existing data with non-idempotent merge ===\n"; (* Create collections with existing data *) - let left, emit_left = source ~name:"left" () in + let left, emit_left = Source.create ~name:"left" () in emit_set emit_left "only_left" 3; - let right, _emit_right = source ~name:"right" () in + 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 ~name:"combined" left right ~merge:( + ) () in + let combined = Union.create ~name:"combined" left right ~merge:( + ) () in assert (length combined = 1); assert (get_opt combined "only_left" = Some 3); diff --git a/analysis/reactive/test/dune b/analysis/reactive/test/dune index ec3ac28bdb5..996fa5775c1 100644 --- a/analysis/reactive/test/dune +++ b/analysis/reactive/test/dune @@ -10,7 +10,7 @@ FixpointIncrementalTest BatchTest IntegrationTest - GlitchFreeTest + GlitchFreeTest AllocMeasure AllocTest TableTest) From f1dd0cbe613b37ab440ae5d964beb10ccc0b9636 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 15:29:37 +0100 Subject: [PATCH 06/54] analysis/reactive: inline node constructors into modules --- analysis/reactive/src/Reactive.ml | 788 +++++++++++++++--------------- 1 file changed, 393 insertions(+), 395 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 00aa7d260d1..7290b2c859a 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -507,428 +507,426 @@ let apply_source_emit (tables : ('k, 'v) source_tables) k mv = ReactiveHash.Map.remove tables.tbl k; ReactiveHash.Map.replace tables.pending k ReactiveMaybe.none) -let source_create ~name () = - let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.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. +module Source = struct + let create ~name () = + let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.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 ReactiveHash.Map for zero-alloc deduplication (last-write-wins). *) - let pending : ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t = - ReactiveHash.Map.create () - in - let tables = {tbl; pending} in - let pending_count = ref 0 in - - let process () = - let count = ReactiveHash.Map.cardinal pending in - if count > 0 then ( - my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; - my_stats.entries_emitted <- my_stats.entries_emitted + count; - ReactiveWave.clear output_wave; - ReactiveHash.Map.iter_with unsafe_wave_push output_wave pending; - ReactiveHash.Map.clear pending; - notify_subscribers output_wave !subscribers) - else ReactiveHash.Map.clear pending - in - - let my_info = Registry.register ~name ~level:0 ~process ~stats:my_stats in - - let collection = - { - name; - subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> ReactiveHash.Map.iter f tbl); - get = (fun k -> ReactiveHash.Map.find_maybe tbl k); - length = (fun () -> ReactiveHash.Map.cardinal tbl); - destroy = (fun () -> ReactiveWave.destroy output_wave); - stats = my_stats; - level = 0; - node = my_info; - } - in + let pending : ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () + in + let tables = {tbl; pending} in + let pending_count = ref 0 in + + let process () = + let count = ReactiveHash.Map.cardinal pending in + if count > 0 then ( + my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; + my_stats.entries_emitted <- my_stats.entries_emitted + count; + ReactiveWave.clear output_wave; + ReactiveHash.Map.iter_with unsafe_wave_push output_wave pending; + ReactiveHash.Map.clear pending; + notify_subscribers output_wave !subscribers) + else ReactiveHash.Map.clear pending + in - let emit (input_wave : ('k, 'v ReactiveMaybe.t) ReactiveWave.t) = - let count = ReactiveWave.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 *) - ReactiveWave.iter_with input_wave apply_source_emit tables; - pending_count := !pending_count + 1; - Registry.mark_dirty_node my_info; - if not (Scheduler.is_propagating ()) then Scheduler.propagate () - in + let my_info = Registry.register ~name ~level:0 ~process ~stats:my_stats in - (collection, emit) + let collection = + { + name; + subscribe = (fun h -> subscribers := h :: !subscribers); + iter = (fun f -> ReactiveHash.Map.iter f tbl); + get = (fun k -> ReactiveHash.Map.find_maybe tbl k); + length = (fun () -> ReactiveHash.Map.cardinal tbl); + destroy = (fun () -> ReactiveWave.destroy output_wave); + stats = my_stats; + level = 0; + node = my_info; + } + in -(** {1 FlatMap} *) + let emit (input_wave : ('k, 'v ReactiveMaybe.t) ReactiveWave.t) = + let count = ReactiveWave.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 *) + ReactiveWave.iter_with input_wave apply_source_emit tables; + pending_count := !pending_count + 1; + Registry.mark_dirty_node my_info; + if not (Scheduler.is_propagating ()) then Scheduler.propagate () + in -let flatmap_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 subscribers = ref [] in - let output_wave = create_wave () in - let my_stats = create_stats () in - let state = ReactiveFlatMap.create ~f ~merge:merge_fn ~output_wave 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 + 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 ( - 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 - - let my_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: push directly into pending map *) - src.subscribe (fun wave -> - Registry.inc_inflight_node src.node; - incr pending_count; - ReactiveWave.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); + (collection, emit) +end - { - 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 = (fun () -> todo_destroy name); - stats = my_stats; - level = my_level; - node = my_info; - } +(** {1 FlatMap} *) -(** {1 Join} *) +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 join_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 subscribers = ref [] in - let output_wave = create_wave () in - let my_stats = create_stats () in - let state = - ReactiveJoin.create ~key_of ~f ~merge:merge_fn ~right_get:right.get - ~output_wave - in - 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 ( - 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 - - let my_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: push directly into pending maps *) - left.subscribe (fun wave -> - Registry.inc_inflight_node left.node; - incr left_pending_count; - ReactiveWave.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; - ReactiveWave.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); + let subscribers = ref [] in + let output_wave = create_wave () in + let my_stats = create_stats () in + let state = ReactiveFlatMap.create ~f ~merge:merge_fn ~output_wave 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 + 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 ( + 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 - { - 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 = (fun () -> todo_destroy name); - stats = my_stats; - level = my_level; - node = my_info; - } + let my_info = + Registry.register ~name ~level:my_level ~process ~stats:my_stats + in + Registry.add_edge ~from_name:src.name ~to_name:name ~label:"flatMap"; -(** {1 Union} *) + (* Subscribe to source: push directly into pending map *) + src.subscribe (fun wave -> + Registry.inc_inflight_node src.node; + incr pending_count; + ReactiveWave.iter_with wave ReactiveFlatMap.push state; + Registry.mark_dirty_node my_info); -let union_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 subscribers = ref [] in - let output_wave = create_wave () in - let my_stats = create_stats () in - let state = ReactiveUnion.create ~merge:merge_fn ~output_wave in - 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 = 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 ( - 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 - - let my_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: push directly into pending maps *) - left.subscribe (fun wave -> - Registry.inc_inflight_node left.node; - incr left_pending_count; - ReactiveWave.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; - ReactiveWave.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); + (* 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 -> ReactiveUnion.iter_target f state); - get = (fun k -> ReactiveUnion.find_target state k); - length = (fun () -> ReactiveUnion.target_length state); - destroy = (fun () -> todo_destroy name); - stats = my_stats; - level = my_level; - node = my_info; - } + { + 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 = (fun () -> todo_destroy name); + stats = my_stats; + level = my_level; + node = my_info; + } +end -(** {1 Fixpoint} *) +(** {1 Join} *) -let fixpoint_create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) 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 - - (* 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 - let max_root_wave_entries = - int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_ROOT_WAVE_ENTRIES" 4_096 - 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 = ReactiveWave.create ~max_entries:max_root_wave_entries in - let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries in - let subscribers = ref [] in - let my_stats = create_stats () in - let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = - ReactiveHash.Map.create () - in - let edge_pending : ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = - ReactiveHash.Map.create () - in - let init_pending_count = ref 0 in - let edges_pending_count = ref 0 in - - let process () = - let consumed_init = !init_pending_count in - let consumed_edges = !edges_pending_count in - init_pending_count := 0; - edges_pending_count := 0; - - 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 *) - ReactiveWave.clear root_wave; - ReactiveWave.clear edge_wave; - let root_entries = ReactiveHash.Map.cardinal root_pending in - let edge_entries = ReactiveHash.Map.cardinal edge_pending in - ReactiveHash.Map.iter_with unsafe_wave_push root_wave root_pending; - ReactiveHash.Map.iter_with unsafe_wave_push edge_wave edge_pending; - ReactiveHash.Map.clear root_pending; - ReactiveHash.Map.clear edge_pending; - - my_stats.entries_received <- - my_stats.entries_received + root_entries + edge_entries; - my_stats.adds_received <- - my_stats.adds_received + root_entries + edge_entries; - - let out_wave = - ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave +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 out_count = ReactiveWave.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 - - let my_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; - - (* 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; - ReactiveWave.iter_with wave unsafe_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; - ReactiveWave.iter_with wave unsafe_wave_map_replace edge_pending; - Registry.mark_dirty_node my_info); - - (* Initialize from existing data *) - let init_roots_wave = - ReactiveWave.create ~max_entries:(max 1 (init.length ())) - in - let init_edges_wave = - ReactiveWave.create ~max_entries:(max 1 (edges.length ())) - in - ReactiveWave.clear init_roots_wave; - ReactiveWave.clear init_edges_wave; - init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); - edges.iter (fun k succs -> unsafe_wave_push init_edges_wave k succs); - ReactiveFixpoint.initialize state ~roots:init_roots_wave - ~edges: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); - destroy = (fun () -> todo_destroy name); - stats = my_stats; - level = my_level; - node = my_info; - } - -(** {1 Utilities} *) + let subscribers = ref [] in + let output_wave = create_wave () in + let my_stats = create_stats () in + let state = + ReactiveJoin.create ~key_of ~f ~merge:merge_fn ~right_get:right.get + ~output_wave + in + 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 ( + 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 -module Source = struct - let create = source_create -end + let my_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: push directly into pending maps *) + left.subscribe (fun wave -> + Registry.inc_inflight_node left.node; + incr left_pending_count; + ReactiveWave.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; + ReactiveWave.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); -module FlatMap = struct - let create = flatmap_create + { + 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 = (fun () -> todo_destroy name); + stats = my_stats; + level = my_level; + node = my_info; + } end -module Join = struct - let create = join_create -end +(** {1 Union} *) module Union = struct - let create = union_create + 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 subscribers = ref [] in + let output_wave = create_wave () in + let my_stats = create_stats () in + let state = ReactiveUnion.create ~merge:merge_fn ~output_wave in + 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 = 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 ( + 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 + + let my_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: push directly into pending maps *) + left.subscribe (fun wave -> + Registry.inc_inflight_node left.node; + incr left_pending_count; + ReactiveWave.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; + ReactiveWave.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 -> ReactiveUnion.iter_target f state); + get = (fun k -> ReactiveUnion.find_target state k); + length = (fun () -> ReactiveUnion.target_length state); + destroy = (fun () -> todo_destroy name); + stats = my_stats; + level = my_level; + node = my_info; + } end +(** {1 Fixpoint} *) + module Fixpoint = struct - let create = fixpoint_create + let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) 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 + + (* 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 + let max_root_wave_entries = + int_env_or "RESCRIPT_REACTIVE_FIXPOINT_MAX_ROOT_WAVE_ENTRIES" 4_096 + 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 = ReactiveWave.create ~max_entries:max_root_wave_entries in + let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries in + let subscribers = ref [] in + let my_stats = create_stats () in + let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () + in + let edge_pending : ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () + in + let init_pending_count = ref 0 in + let edges_pending_count = ref 0 in + + let process () = + let consumed_init = !init_pending_count in + let consumed_edges = !edges_pending_count in + init_pending_count := 0; + edges_pending_count := 0; + + 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 *) + ReactiveWave.clear root_wave; + ReactiveWave.clear edge_wave; + let root_entries = ReactiveHash.Map.cardinal root_pending in + let edge_entries = ReactiveHash.Map.cardinal edge_pending in + ReactiveHash.Map.iter_with unsafe_wave_push root_wave root_pending; + ReactiveHash.Map.iter_with unsafe_wave_push edge_wave edge_pending; + ReactiveHash.Map.clear root_pending; + ReactiveHash.Map.clear edge_pending; + + my_stats.entries_received <- + my_stats.entries_received + root_entries + edge_entries; + my_stats.adds_received <- + my_stats.adds_received + root_entries + edge_entries; + + let out_wave = + ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave + in + let out_count = ReactiveWave.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 + + let my_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; + + (* 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; + ReactiveWave.iter_with wave unsafe_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; + ReactiveWave.iter_with wave unsafe_wave_map_replace edge_pending; + Registry.mark_dirty_node my_info); + + (* Initialize from existing data *) + let init_roots_wave = + ReactiveWave.create ~max_entries:(max 1 (init.length ())) + in + let init_edges_wave = + ReactiveWave.create ~max_entries:(max 1 (edges.length ())) + in + ReactiveWave.clear init_roots_wave; + ReactiveWave.clear init_edges_wave; + init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); + edges.iter (fun k succs -> unsafe_wave_push init_edges_wave k succs); + ReactiveFixpoint.initialize state ~roots:init_roots_wave + ~edges: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); + destroy = (fun () -> todo_destroy name); + 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 From c4d0246899963f4aab72dd3333944fe6bdfb5702 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 15:31:20 +0100 Subject: [PATCH 07/54] analysis/reactive: localize node-specific helpers --- analysis/reactive/src/Reactive.ml | 44 +++++++++++++++---------------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 7290b2c859a..cd7da4a6a9b 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -482,32 +482,25 @@ let unsafe_wave_push wave k v = (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap v) -let unsafe_wave_map_replace pending k v = - ReactiveHash.Map.replace pending - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v) - (** {1 Source Collection} *) -(* Module-level helper for source emit — avoids closure allocation. - Groups tbl + pending so iter_with can pass a single argument. *) -type ('k, 'v) source_tables = { - tbl: ('k, 'v) ReactiveHash.Map.t; - pending: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; -} +module Source = struct + type ('k, 'v) tables = { + tbl: ('k, 'v) ReactiveHash.Map.t; + pending: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; + } -let apply_source_emit (tables : ('k, 'v) source_tables) k mv = - let k = ReactiveAllocator.unsafe_from_offheap k in - let mv = ReactiveAllocator.unsafe_from_offheap mv in - if ReactiveMaybe.is_some mv then ( - let v = ReactiveMaybe.unsafe_get mv in - ReactiveHash.Map.replace tables.tbl k v; - ReactiveHash.Map.replace tables.pending k (ReactiveMaybe.some v)) - else ( - ReactiveHash.Map.remove tables.tbl k; - ReactiveHash.Map.replace tables.pending k ReactiveMaybe.none) + let apply_emit (tables : ('k, 'v) tables) k mv = + let k = ReactiveAllocator.unsafe_from_offheap k in + let mv = ReactiveAllocator.unsafe_from_offheap mv in + if ReactiveMaybe.is_some mv then ( + let v = ReactiveMaybe.unsafe_get mv in + ReactiveHash.Map.replace tables.tbl k v; + ReactiveHash.Map.replace tables.pending k (ReactiveMaybe.some v)) + else ( + ReactiveHash.Map.remove tables.tbl k; + ReactiveHash.Map.replace tables.pending k ReactiveMaybe.none) -module Source = struct let create ~name () = let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.create () in let subscribers = ref [] in @@ -554,7 +547,7 @@ module Source = struct 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 *) - ReactiveWave.iter_with input_wave apply_source_emit tables; + ReactiveWave.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 () @@ -804,6 +797,11 @@ end (** {1 Fixpoint} *) module Fixpoint = struct + let unsafe_wave_map_replace pending k v = + ReactiveHash.Map.replace pending + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v) + let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = let my_level = max init.level edges.level + 1 in From 8cc0c30f6cd24c44c0e9af88fa2945c07ee59927 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 15:39:47 +0100 Subject: [PATCH 08/54] analysis/reactive: clean up allocation test teardowns --- analysis/reactive/test/AllocTest.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index bba5193a13f..5d8ddbe3c54 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -195,6 +195,7 @@ let test_union_alloc_n n = ignore (ReactiveUnion.process state) done; assert (ReactiveUnion.target_length state = n); + ReactiveWave.destroy output_wave; words_since () / iters let test_union_alloc () = @@ -265,6 +266,7 @@ let test_join_alloc_n n = ignore (ReactiveJoin.process state) done; assert (ReactiveJoin.target_length state = n); + ReactiveWave.destroy output_wave; words_since () / iters let test_join_alloc () = @@ -449,12 +451,11 @@ let test_reactive_union_alloc_n n = emit_left add_wave done; assert (Reactive.length merged = n); - let words = words_since () / iters in ReactiveWave.destroy remove_wave; ReactiveWave.destroy add_wave; Reactive.destroy left; Reactive.destroy right; - words + words_since () / iters let test_reactive_union_alloc () = reset_offheap_state (); From fb0ed74637f8b1275c7b0a398e728af331fb553a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 15:42:06 +0100 Subject: [PATCH 09/54] analysis/reactive: clean up direct allocation test waves --- analysis/reactive/test/AllocTest.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 5d8ddbe3c54..648544d0409 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -138,6 +138,7 @@ let test_flatmap_alloc_n n = ignore (ReactiveFlatMap.process state) done; assert (ReactiveFlatMap.target_length state = n); + ReactiveWave.destroy output_wave; words_since () / iters let test_flatmap_alloc () = @@ -706,14 +707,14 @@ let test_pool_map_map_pattern_remove_recycle_churn () = let run_all () = Printf.printf "\n====== Allocation Tests ======\n\n"; - test_fixpoint_alloc (); test_union_alloc (); test_flatmap_alloc (); test_join_alloc (); - test_reactive_fixpoint_alloc (); + test_fixpoint_alloc (); test_reactive_union_alloc (); test_reactive_flatmap_alloc (); test_reactive_join_alloc (); + test_reactive_fixpoint_alloc (); test_pool_map_set_pattern_drain_key_churn (); test_pool_map_set_pattern_remove_recycle_churn (); test_pool_map_map_pattern_drain_outer_churn (); From f25a1a76913df9b3384923b856a791ef070eb794 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 15:53:39 +0100 Subject: [PATCH 10/54] analysis/reactive: add fixpoint destroy Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 2 ++ analysis/reactive/src/ReactiveFixpoint.mli | 4 ++++ analysis/reactive/test/AllocTest.ml | 20 +++++++++++--------- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index e5c03fb0a24..4dd9adc8d98 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -432,6 +432,8 @@ let create ~max_nodes ~max_edges = }; } +let destroy t = ReactiveWave.destroy t.output_wave + type 'k root_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t type 'k edge_wave = ('k, 'k list ReactiveMaybe.t) ReactiveWave.t type 'k output_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 8cee2688f4b..34ffe407ba3 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -14,6 +14,10 @@ val create : max_nodes:int -> max_edges:int -> 'k t Raises [Invalid_argument] if capacities are not positive. *) +val destroy : 'k t -> unit +(** Release fixpoint-owned off-heap storage. The state must not be used + afterwards. *) + val iter_current : 'k t -> ('k -> unit -> unit) -> unit val get_current : 'k t -> 'k -> unit ReactiveMaybe.t val current_length : 'k t -> int diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 648544d0409..f3ce556d7a8 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -38,11 +38,14 @@ let print_offheap_snapshot label = 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 = ReactiveWave.create ~max_entries:1 in + let edge_snap = ReactiveWave.create ~max_entries:n in + let remove_root = ReactiveWave.create ~max_entries:1 in + let add_root = ReactiveWave.create ~max_entries:1 in + let no_edges = ReactiveWave.create ~max_entries:1 in let state = ReactiveFixpoint.create ~max_nodes:n ~max_edges:n in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) - let root_snap = ReactiveWave.create ~max_entries:1 in - let edge_snap = ReactiveWave.create ~max_entries:n in ReactiveWave.push root_snap (off_int 0) (off_unit ()); for i = 0 to n - 2 do ReactiveWave.push edge_snap (off_int i) @@ -52,12 +55,9 @@ let test_fixpoint_alloc_n n = assert (ReactiveFixpoint.current_length state = n); (* Pre-build waves once *) - let remove_root = ReactiveWave.create ~max_entries:1 in ReactiveWave.push remove_root (off_int 0) ReactiveMaybe.none_offheap; - let add_root = ReactiveWave.create ~max_entries:1 in ReactiveWave.push add_root (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); - let no_edges = ReactiveWave.create ~max_entries:1 in (* Warmup *) for _ = 1 to 5 do @@ -76,6 +76,12 @@ let test_fixpoint_alloc_n n = ignore (ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges) done; assert (ReactiveFixpoint.current_length state = n); + ReactiveWave.destroy root_snap; + ReactiveWave.destroy edge_snap; + ReactiveWave.destroy remove_root; + ReactiveWave.destroy add_root; + ReactiveWave.destroy no_edges; + ReactiveFixpoint.destroy state; words_since () / iters let test_fixpoint_alloc () = @@ -410,14 +416,10 @@ let test_reactive_fixpoint_alloc () = let test_reactive_union_alloc_n n = Reactive.reset (); - print_offheap_snapshot "before sources"; let left, emit_left = Reactive.Source.create ~name:"left" () in - print_offheap_snapshot "after left source"; let right, emit_right = Reactive.Source.create ~name:"right" () in - print_offheap_snapshot "after right source"; let merged = Reactive.Union.create ~name:"merged" left right () in - print_offheap_snapshot "after union"; (* Populate: n entries on the left side *) for i = 0 to n - 1 do From fb3001b5d32b84a6ceabf3f8f43dfe46d2335c98 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 16:40:49 +0100 Subject: [PATCH 11/54] analysis/reactive: add graph destroy and own union waves --- analysis/reactive/src/Reactive.ml | 58 +++++++++++++++++-------- analysis/reactive/src/Reactive.mli | 6 +++ analysis/reactive/src/ReactiveUnion.ml | 8 +++- analysis/reactive/src/ReactiveUnion.mli | 14 +++--- analysis/reactive/test/AllocTest.ml | 8 ++-- 5 files changed, 64 insertions(+), 30 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index cd7da4a6a9b..1c73c26d2cd 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -70,6 +70,7 @@ module Registry = struct mutable dirty: bool; mutable outbound_inflight: int; process: unit -> unit; (* Process accumulated deltas *) + destroy: unit -> unit; stats: stats; } @@ -84,11 +85,11 @@ module Registry = struct let dirty_count = ref 0 (* Pre-sorted node array for zero-alloc propagation. - Built lazily on first propagate; invalidated by register. *) + Built lazily on first propagate; invalidated by register_node. *) let sorted_nodes : node_info array ref = ref [||] let sorted_valid = ref true - let register ~name ~level ~process ~stats = + let register_node ~name ~level ~process ~destroy ~stats = let info = { name; @@ -98,6 +99,7 @@ module Registry = struct dirty = false; outbound_inflight = 0; process; + destroy; stats; } in @@ -154,6 +156,12 @@ module Registry = struct sorted_nodes := [||]; sorted_valid := true + let destroy_graph () = + let all = Hashtbl.fold (fun _ info acc -> info :: acc) nodes [] in + let sorted = List.sort (fun a b -> compare b.level a.level) all in + List.iter (fun info -> info.destroy ()) sorted; + clear () + let reset_stats () = Hashtbl.iter (fun _ info -> @@ -473,10 +481,6 @@ let stats t = t.stats let level t = t.level let name t = t.name -let todo_destroy name = - Printf.eprintf "TODO: Reactive.destroy for node %s\n%!" name; - assert false - let unsafe_wave_push wave k v = ReactiveWave.push wave (ReactiveAllocator.unsafe_to_offheap k) @@ -526,7 +530,10 @@ module Source = struct else ReactiveHash.Map.clear pending in - let my_info = Registry.register ~name ~level:0 ~process ~stats:my_stats in + let destroy () = ReactiveWave.destroy output_wave in + let my_info = + Registry.register_node ~name ~level:0 ~process ~destroy ~stats:my_stats + in let collection = { @@ -535,7 +542,7 @@ module Source = struct iter = (fun f -> ReactiveHash.Map.iter f tbl); get = (fun k -> ReactiveHash.Map.find_maybe tbl k); length = (fun () -> ReactiveHash.Map.cardinal tbl); - destroy = (fun () -> ReactiveWave.destroy output_wave); + destroy; stats = my_stats; level = 0; node = my_info; @@ -596,8 +603,10 @@ module FlatMap = struct notify_subscribers output_wave !subscribers) in + let destroy () = ReactiveWave.destroy output_wave in let my_info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats + 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"; @@ -617,7 +626,7 @@ module FlatMap = struct iter = (fun f -> ReactiveFlatMap.iter_target f state); get = (fun k -> ReactiveFlatMap.find_target state k); length = (fun () -> ReactiveFlatMap.target_length state); - destroy = (fun () -> todo_destroy name); + destroy; stats = my_stats; level = my_level; node = my_info; @@ -673,8 +682,10 @@ module Join = struct notify_subscribers output_wave !subscribers) in + let destroy () = ReactiveWave.destroy output_wave in let my_info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats + 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"; @@ -703,7 +714,7 @@ module Join = struct iter = (fun f -> ReactiveJoin.iter_target f state); get = (fun k -> ReactiveJoin.find_target state k); length = (fun () -> ReactiveJoin.target_length state); - destroy = (fun () -> todo_destroy name); + destroy; stats = my_stats; level = my_level; node = my_info; @@ -723,9 +734,8 @@ module Union = struct in let subscribers = ref [] in - let output_wave = create_wave () in let my_stats = create_stats () in - let state = ReactiveUnion.create ~merge:merge_fn ~output_wave in + let state = ReactiveUnion.create ~merge:merge_fn in let left_pending_count = ref 0 in let right_pending_count = ref 0 in @@ -749,6 +759,7 @@ module Union = struct 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; @@ -756,8 +767,10 @@ module Union = struct notify_subscribers output_wave !subscribers) in + let destroy () = ReactiveUnion.destroy state in let my_info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats + 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"; @@ -787,7 +800,7 @@ module Union = struct iter = (fun f -> ReactiveUnion.iter_target f state); get = (fun k -> ReactiveUnion.find_target state k); length = (fun () -> ReactiveUnion.target_length state); - destroy = (fun () -> todo_destroy name); + destroy; stats = my_stats; level = my_level; node = my_info; @@ -875,8 +888,14 @@ module Fixpoint = struct my_stats.entries_emitted <- my_stats.entries_emitted + out_count) in + let destroy () = + ReactiveWave.destroy root_wave; + ReactiveWave.destroy edge_wave; + ReactiveFixpoint.destroy state + in let my_info = - Registry.register ~name ~level:my_level ~process ~stats:my_stats + 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"; @@ -909,6 +928,8 @@ module Fixpoint = struct edges.iter (fun k succs -> unsafe_wave_push init_edges_wave k succs); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; + ReactiveWave.destroy init_roots_wave; + ReactiveWave.destroy init_edges_wave; { name; @@ -916,7 +937,7 @@ module Fixpoint = struct iter = (fun f -> ReactiveFixpoint.iter_current state f); get = (fun k -> ReactiveFixpoint.get_current state k); length = (fun () -> ReactiveFixpoint.current_length state); - destroy = (fun () -> todo_destroy name); + destroy; stats = my_stats; level = my_level; node = my_info; @@ -928,5 +949,6 @@ end 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 33589a6dece..264e3be8bdf 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -43,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 *) @@ -173,5 +176,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/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index cc96dcb67e4..f0c983fba2f 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -25,7 +25,7 @@ and process_result = { mutable removes_emitted: int; } -let create ~merge ~output_wave = +let create ~merge = { merge; left_values = ReactiveHash.Map.create (); @@ -34,7 +34,7 @@ let create ~merge ~output_wave = left_scratch = ReactiveHash.Map.create (); right_scratch = ReactiveHash.Map.create (); affected = ReactiveHash.Set.create (); - output_wave; + output_wave = ReactiveWave.create ~max_entries:16; result = { entries_received = 0; @@ -46,6 +46,10 @@ let create ~merge ~output_wave = }; } +let destroy t = ReactiveWave.destroy t.output_wave + +let output_wave t = t.output_wave + let push_left t k mv = ReactiveHash.Map.replace t.left_scratch (ReactiveAllocator.unsafe_from_offheap k) diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index c3b46ecf5c8..386d21e1d26 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -13,11 +13,15 @@ type process_result = { mutable removes_emitted: int; } -val create : - merge:('v -> 'v -> 'v) -> - output_wave:('k, 'v ReactiveMaybe.t) ReactiveWave.t -> - ('k, 'v) t -(** Create union state with the given merge function and output wave buffer. *) +val create : merge:('v -> 'v -> 'v) -> ('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 off-heap storage. The state must not be used + afterwards. *) + +val output_wave : ('k, 'v) t -> ('k, 'v ReactiveMaybe.t) ReactiveWave.t +(** The owned output wave populated by [process]. *) val push_left : ('k, 'v) t -> diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index f3ce556d7a8..0b686c8b54a 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -161,8 +161,7 @@ let test_flatmap_alloc () = (* ---- Union allocation ---- *) let test_union_alloc_n n = - let output_wave = ReactiveWave.create ~max_entries:(n * 2) in - let state = ReactiveUnion.create ~merge:(fun _l r -> r) ~output_wave in + let state = ReactiveUnion.create ~merge:(fun _l r -> r) in (* Populate: n entries on the left side *) for i = 0 to n - 1 do @@ -202,7 +201,7 @@ let test_union_alloc_n n = ignore (ReactiveUnion.process state) done; assert (ReactiveUnion.target_length state = n); - ReactiveWave.destroy output_wave; + ReactiveUnion.destroy state; words_since () / iters let test_union_alloc () = @@ -456,8 +455,7 @@ let test_reactive_union_alloc_n n = assert (Reactive.length merged = n); ReactiveWave.destroy remove_wave; ReactiveWave.destroy add_wave; - Reactive.destroy left; - Reactive.destroy right; + Reactive.destroy_graph (); words_since () / iters let test_reactive_union_alloc () = From 257f1031c3eb282d5cddeedb4218cf99c1e726bd Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 16:50:35 +0100 Subject: [PATCH 12/54] analysis/reactive: simplify wave creation and own flatmap waves --- analysis/reactive/src/Reactive.ml | 24 ++++-------- .../reactive/src/ReactiveFileCollection.ml | 2 +- analysis/reactive/src/ReactiveFixpoint.ml | 2 +- analysis/reactive/src/ReactiveFlatMap.ml | 8 +++- analysis/reactive/src/ReactiveFlatMap.mli | 9 ++++- analysis/reactive/src/ReactiveUnion.ml | 2 +- analysis/reactive/src/ReactiveWave.ml | 2 +- analysis/reactive/src/ReactiveWave.mli | 6 +-- analysis/reactive/test/AllocTest.ml | 38 +++++++++---------- analysis/reactive/test/TestHelpers.ml | 2 +- 10 files changed, 47 insertions(+), 48 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 1c73c26d2cd..419cb1d9b19 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -11,15 +11,7 @@ type ('k, 'v) wave = ('k, 'v ReactiveMaybe.t) ReactiveWave.t -let wave_max_entries_default = - match Sys.getenv_opt "RESCRIPT_REACTIVE_WAVE_MAX_ENTRIES" with - | Some s -> ( - match int_of_string_opt s with - | Some n when n > 0 -> n - | _ -> 16) - | None -> 16 - -let create_wave () = ReactiveWave.create ~max_entries:wave_max_entries_default +let create_wave () = ReactiveWave.create () (** {1 Statistics} *) @@ -575,9 +567,8 @@ module FlatMap = struct in let subscribers = ref [] in - let output_wave = create_wave () in let my_stats = create_stats () in - let state = ReactiveFlatMap.create ~f ~merge:merge_fn ~output_wave in + let state = ReactiveFlatMap.create ~f ~merge:merge_fn in let pending_count = ref 0 in let process () = @@ -596,6 +587,7 @@ module FlatMap = struct 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 + r.entries_emitted; my_stats.adds_emitted <- my_stats.adds_emitted + r.adds_emitted; @@ -603,7 +595,7 @@ module FlatMap = struct notify_subscribers output_wave !subscribers) in - let destroy () = ReactiveWave.destroy output_wave in + let destroy () = ReactiveFlatMap.destroy state in let my_info = Registry.register_node ~name ~level:my_level ~process ~destroy ~stats:my_stats @@ -839,8 +831,8 @@ module Fixpoint = struct 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 = ReactiveWave.create ~max_entries:max_root_wave_entries in - let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries in + let root_wave = ReactiveWave.create ~max_entries:max_root_wave_entries () in + let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries () in let subscribers = ref [] in let my_stats = create_stats () in let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = @@ -917,10 +909,10 @@ module Fixpoint = struct (* Initialize from existing data *) let init_roots_wave = - ReactiveWave.create ~max_entries:(max 1 (init.length ())) + ReactiveWave.create ~max_entries:(max 1 (init.length ())) () in let init_edges_wave = - ReactiveWave.create ~max_entries:(max 1 (edges.length ())) + ReactiveWave.create ~max_entries:(max 1 (edges.length ())) () in ReactiveWave.clear init_roots_wave; ReactiveWave.clear init_edges_wave; diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index 321046f0d86..5477c097aa2 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -32,7 +32,7 @@ type ('raw, 'v) t = { let create ~read_file ~process : ('raw, 'v) t = let internal = {cache = Hashtbl.create 256; read_file; process} in let collection, emit = Reactive.Source.create ~name:"file_collection" () in - let scratch_wave = ReactiveWave.create ~max_entries:16 in + let scratch_wave = ReactiveWave.create () in {internal; collection; emit; scratch_wave} (** Get the collection interface for composition *) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 4dd9adc8d98..b0ea4b7e913 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -405,7 +405,7 @@ let create ~max_nodes ~max_edges = edge_map = ReactiveHash.Map.create (); pred_map = ReactivePoolMapSet.create ~capacity:128; roots = ReactiveHash.Map.create (); - output_wave = ReactiveWave.create ~max_entries:max_nodes; + output_wave = ReactiveWave.create ~max_entries:max_nodes (); deleted_nodes = ReactiveHash.Map.create (); rederive_pending = ReactiveHash.Map.create (); expansion_seen = ReactiveHash.Map.create (); diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index d7fd9b833a8..16dfa4d86b0 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -48,7 +48,7 @@ let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; ReactiveHash.Map.replace t.target k2 v2 -let create ~f ~merge ~output_wave = +let create ~f ~merge = let rec t = { f; @@ -58,7 +58,7 @@ let create ~f ~merge ~output_wave = target = ReactiveHash.Map.create (); scratch = ReactiveHash.Map.create (); affected = ReactiveHash.Set.create (); - output_wave; + output_wave = ReactiveWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k2 v2 -> add_single_contribution t k2 v2); result = @@ -76,6 +76,10 @@ let create ~f ~merge ~output_wave = in t +let destroy t = ReactiveWave.destroy t.output_wave + +let output_wave t = t.output_wave + let push t k v_opt = ReactiveHash.Map.replace t.scratch (ReactiveAllocator.unsafe_from_offheap k) diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 9ccf8313453..69bed51e8ce 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -16,9 +16,16 @@ type process_result = { val create : f:('k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> merge:('v2 -> 'v2 -> 'v2) -> - output_wave:('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t -> ('k1, 'v1, 'k2, 'v2) t +val destroy : ('k1, 'v1, 'k2, 'v2) t -> unit +(** Release flatMap-owned off-heap storage. The state must not be used + afterwards. *) + +val output_wave : + ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t +(** The owned output wave populated by [process]. *) + val push : ('k1, 'v1, 'k2, 'v2) t -> 'k1 ReactiveAllocator.offheap -> diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index f0c983fba2f..9db67b5b148 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -34,7 +34,7 @@ let create ~merge = left_scratch = ReactiveHash.Map.create (); right_scratch = ReactiveHash.Map.create (); affected = ReactiveHash.Set.create (); - output_wave = ReactiveWave.create ~max_entries:16; + output_wave = ReactiveWave.create (); result = { entries_received = 0; diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index 7d6317f383b..4aac4a47892 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -12,7 +12,7 @@ let set_length t len = ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.int_to_offheap len) -let create ~max_entries = +let create ?(max_entries = 16) () = if max_entries < 0 then invalid_arg "ReactiveWave.create: max_entries must be >= 0"; let t = diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli index cc41dfe896f..9b5d630f4cc 100644 --- a/analysis/reactive/src/ReactiveWave.mli +++ b/analysis/reactive/src/ReactiveWave.mli @@ -6,9 +6,9 @@ type ('k, 'v) t -val create : max_entries:int -> ('k, 'v) t -(** Create an empty wave with an initial capacity hint. The wave grows - automatically if that capacity is exceeded. *) +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. *) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 0b686c8b54a..d17139114f7 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -38,11 +38,11 @@ let print_offheap_snapshot label = 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 = ReactiveWave.create ~max_entries:1 in - let edge_snap = ReactiveWave.create ~max_entries:n in - let remove_root = ReactiveWave.create ~max_entries:1 in - let add_root = ReactiveWave.create ~max_entries:1 in - let no_edges = ReactiveWave.create ~max_entries:1 in + let root_snap = ReactiveWave.create ~max_entries:1 () in + let edge_snap = ReactiveWave.create ~max_entries:n () in + let remove_root = ReactiveWave.create ~max_entries:1 () in + let add_root = ReactiveWave.create ~max_entries:1 () in + let no_edges = ReactiveWave.create ~max_entries:1 () in let state = ReactiveFixpoint.create ~max_nodes:n ~max_edges:n in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) @@ -98,12 +98,8 @@ let test_fixpoint_alloc () = (* ---- FlatMap allocation ---- *) let test_flatmap_alloc_n n = - let output_wave = ReactiveWave.create ~max_entries:(n * 2) in let state = - ReactiveFlatMap.create - ~f:(fun k v emit -> emit k v) - ~merge:(fun _l r -> r) - ~output_wave + ReactiveFlatMap.create ~f:(fun k v emit -> emit k v) ~merge:(fun _l r -> r) in (* Populate: n entries *) @@ -144,7 +140,7 @@ let test_flatmap_alloc_n n = ignore (ReactiveFlatMap.process state) done; assert (ReactiveFlatMap.target_length state = n); - ReactiveWave.destroy output_wave; + ReactiveFlatMap.destroy state; words_since () / iters let test_flatmap_alloc () = @@ -218,7 +214,7 @@ let test_union_alloc () = (* ---- Join allocation ---- *) let test_join_alloc_n n = - let output_wave = ReactiveWave.create ~max_entries:(n * 2) in + let output_wave = ReactiveWave.create ~max_entries:(n * 2) () in let right_tbl = ReactiveHash.Map.create () in let state = ReactiveJoin.create @@ -313,11 +309,11 @@ let test_reactive_join_alloc_n n = assert (Reactive.length joined = n); (* Pre-build waves for the hot loop: toggle all left entries *) - let remove_wave = ReactiveWave.create ~max_entries:n in + let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap done; - let add_wave = ReactiveWave.create ~max_entries:n in + let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do unsafe_wave_push add_wave i (ReactiveMaybe.some i) done; @@ -362,7 +358,7 @@ let test_reactive_fixpoint_alloc_n n = let edges, emit_edges = Reactive.Source.create ~name:"edges" () in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) - let edge_wave = ReactiveWave.create ~max_entries:(max 1 (n - 1)) in + let edge_wave = ReactiveWave.create ~max_entries:(max 1 (n - 1)) () in ReactiveWave.clear edge_wave; for i = 0 to n - 2 do ReactiveWave.push edge_wave (off_int i) @@ -376,9 +372,9 @@ let test_reactive_fixpoint_alloc_n n = assert (Reactive.length reachable = n); (* Pre-build waves for the hot loop *) - let remove_wave = ReactiveWave.create ~max_entries:1 in + let remove_wave = ReactiveWave.create ~max_entries:1 () in ReactiveWave.push remove_wave (off_int 0) ReactiveMaybe.none_offheap; - let add_wave = ReactiveWave.create ~max_entries:1 in + let add_wave = ReactiveWave.create ~max_entries:1 () in ReactiveWave.push add_wave (off_int 0) (off_maybe_unit (ReactiveMaybe.some ())); @@ -427,11 +423,11 @@ let test_reactive_union_alloc_n n = assert (Reactive.length merged = n); (* Pre-build waves: single wave with all n entries *) - let remove_wave = ReactiveWave.create ~max_entries:n in + let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap done; - let add_wave = ReactiveWave.create ~max_entries:n in + let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do unsafe_wave_push add_wave i (ReactiveMaybe.some i) done; @@ -486,11 +482,11 @@ let test_reactive_flatmap_alloc_n n = assert (Reactive.length derived = n); (* Pre-build waves *) - let remove_wave = ReactiveWave.create ~max_entries:n in + let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap done; - let add_wave = ReactiveWave.create ~max_entries:n in + let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do unsafe_wave_push add_wave i (ReactiveMaybe.some i) done; diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 2ebd3fd9589..b5e046a778f 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -9,7 +9,7 @@ open Reactive 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) ReactiveWave.t = - ReactiveWave.create ~max_entries:16 + ReactiveWave.create () let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave From a89cbcef7c79b35c3fc0d8f748ba15ab0a297aeb Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 16:55:26 +0100 Subject: [PATCH 13/54] analysis/reactive: own join waves in low-level state --- analysis/reactive/src/Reactive.ml | 5 ++--- analysis/reactive/src/ReactiveJoin.ml | 8 ++++++-- analysis/reactive/src/ReactiveJoin.mli | 9 ++++++++- analysis/reactive/test/AllocTest.ml | 4 +--- analysis/reactive/test/TestHelpers.ml | 3 +-- 5 files changed, 18 insertions(+), 11 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 419cb1d9b19..4f13cbed31a 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -638,11 +638,9 @@ module Join = struct in let subscribers = ref [] in - let output_wave = create_wave () in let my_stats = create_stats () in let state = ReactiveJoin.create ~key_of ~f ~merge:merge_fn ~right_get:right.get - ~output_wave in let left_pending_count = ref 0 in let right_pending_count = ref 0 in @@ -667,6 +665,7 @@ module Join = struct 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; @@ -674,7 +673,7 @@ module Join = struct notify_subscribers output_wave !subscribers) in - let destroy () = ReactiveWave.destroy output_wave in + let destroy () = ReactiveJoin.destroy state in let my_info = Registry.register_node ~name ~level:my_level ~process ~destroy ~stats:my_stats diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 5145a1b8d5a..d634a6617cf 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -54,7 +54,7 @@ let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; ReactiveHash.Map.replace t.target k3 v3 -let create ~key_of ~f ~merge ~right_get ~output_wave = +let create ~key_of ~f ~merge ~right_get = let rec t = { key_of; @@ -70,7 +70,7 @@ let create ~key_of ~f ~merge ~right_get ~output_wave = left_scratch = ReactiveHash.Map.create (); right_scratch = ReactiveHash.Map.create (); affected = ReactiveHash.Set.create (); - output_wave; + output_wave = ReactiveWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k3 v3 -> add_single_contribution t k3 v3); result = @@ -88,6 +88,10 @@ let create ~key_of ~f ~merge ~right_get ~output_wave = in t +let destroy t = ReactiveWave.destroy t.output_wave + +let output_wave t = t.output_wave + let push_left t k v_opt = ReactiveHash.Map.replace t.left_scratch (ReactiveAllocator.unsafe_from_offheap k) diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index 4862da72593..bc61b6b144d 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -18,9 +18,16 @@ val create : f:('k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> merge:('v3 -> 'v3 -> 'v3) -> right_get:('k2 -> 'v2 ReactiveMaybe.t) -> - output_wave:('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t -> ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t +val destroy : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit +(** Release join-owned off-heap storage. The state must not be used + afterwards. *) + +val output_wave : + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> ('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t +(** The owned output wave populated by [process]. *) + val push_left : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k1 ReactiveAllocator.offheap -> diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index d17139114f7..0ff0ba62ab2 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -214,7 +214,6 @@ let test_union_alloc () = (* ---- Join allocation ---- *) let test_join_alloc_n n = - let output_wave = ReactiveWave.create ~max_entries:(n * 2) () in let right_tbl = ReactiveHash.Map.create () in let state = ReactiveJoin.create @@ -224,7 +223,6 @@ let test_join_alloc_n n = emit k (v + ReactiveMaybe.unsafe_get right_mb)) ~merge:(fun _l r -> r) ~right_get:(ReactiveHash.Map.find_maybe right_tbl) - ~output_wave in (* Populate: n entries on the right, n on the left *) @@ -268,7 +266,7 @@ let test_join_alloc_n n = ignore (ReactiveJoin.process state) done; assert (ReactiveJoin.target_length state = n); - ReactiveWave.destroy output_wave; + ReactiveJoin.destroy state; words_since () / iters let test_join_alloc () = diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index b5e046a778f..e2a9c7eec41 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -8,8 +8,7 @@ open Reactive 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) ReactiveWave.t = - ReactiveWave.create () +let scratch_wave : (int, int) ReactiveWave.t = ReactiveWave.create () let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave From c5b70c3d5ea952e32c993f8fab1c16c7401213c6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 16:57:09 +0100 Subject: [PATCH 14/54] analysis/reactive: make fixpoint output wave owned --- analysis/reactive/src/Reactive.ml | 5 ++--- analysis/reactive/src/ReactiveFixpoint.ml | 3 ++- analysis/reactive/src/ReactiveFixpoint.mli | 9 +++++---- analysis/reactive/test/AllocTest.ml | 10 ++++------ 4 files changed, 13 insertions(+), 14 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 4f13cbed31a..d043aa600e7 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -869,9 +869,8 @@ module Fixpoint = struct my_stats.adds_received <- my_stats.adds_received + root_entries + edge_entries; - let out_wave = - ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave - in + ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave; + let out_wave = ReactiveFixpoint.output_wave state in let out_count = ReactiveWave.count out_wave in if out_count > 0 then ( notify_subscribers out_wave !subscribers; diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index b0ea4b7e913..53549038e91 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -433,6 +433,7 @@ let create ~max_nodes ~max_edges = } let destroy t = ReactiveWave.destroy t.output_wave +let output_wave t = t.output_wave type 'k root_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t type 'k edge_wave = ('k, 'k list ReactiveMaybe.t) ReactiveWave.t @@ -798,4 +799,4 @@ let apply_list t ~roots ~edges = let apply_wave t ~roots ~edges = ReactiveWave.clear t.output_wave; apply_list t ~roots ~edges; - t.output_wave + () diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 34ffe407ba3..a5a9bcd31c5 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -18,6 +18,9 @@ val destroy : 'k t -> unit (** Release fixpoint-owned off-heap 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 -> unit -> unit) -> unit val get_current : 'k t -> 'k -> unit ReactiveMaybe.t val current_length : 'k t -> int @@ -27,10 +30,8 @@ val initialize : (** Replace roots and edges from snapshots (full overwrite), then recompute closure. *) -val apply_wave : - 'k t -> roots:'k root_wave -> edges:'k edge_wave -> 'k output_wave -(** Apply one incremental update wave and return closure delta entries as an - output wave. +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/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 0ff0ba62ab2..1e09eba39e8 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -61,9 +61,8 @@ let test_fixpoint_alloc_n n = (* Warmup *) for _ = 1 to 5 do - ignore - (ReactiveFixpoint.apply_wave state ~roots:remove_root ~edges:no_edges); - ignore (ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges) + 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); @@ -71,9 +70,8 @@ let test_fixpoint_alloc_n n = let iters = 100 in ignore (words_since ()); for _ = 1 to iters do - ignore - (ReactiveFixpoint.apply_wave state ~roots:remove_root ~edges:no_edges); - ignore (ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges) + 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); ReactiveWave.destroy root_snap; From 0d4c55fdde2ef685d39242ae320c45bdc9c21a1f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 17:01:30 +0100 Subject: [PATCH 15/54] analysis/reactive: simplify graph destroy traversal --- analysis/reactive/src/Reactive.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index d043aa600e7..790764deacb 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -149,9 +149,7 @@ module Registry = struct sorted_valid := true let destroy_graph () = - let all = Hashtbl.fold (fun _ info acc -> info :: acc) nodes [] in - let sorted = List.sort (fun a b -> compare b.level a.level) all in - List.iter (fun info -> info.destroy ()) sorted; + Hashtbl.iter (fun _ info -> info.destroy ()) nodes; clear () let reset_stats () = From 954100b983fe3b9a18c241c6376fc6d9d0ddbe89 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 17:14:21 +0100 Subject: [PATCH 16/54] analysis/reactive: update reanalyze to new reactive APIs --- analysis/reactive/test/AllocTest.ml | 10 ++++++ analysis/reanalyze/src/ReactiveAnalysis.ml | 2 +- analysis/reanalyze/src/ReactiveDeclRefs.ml | 13 +++---- .../reanalyze/src/ReactiveExceptionRefs.ml | 7 ++-- analysis/reanalyze/src/ReactiveLiveness.ml | 25 ++++++++------ analysis/reanalyze/src/ReactiveMerge.ml | 16 ++++----- analysis/reanalyze/src/ReactiveSolver.ml | 28 ++++++++------- analysis/reanalyze/src/ReactiveTypeDeps.ml | 34 +++++++++++-------- 8 files changed, 78 insertions(+), 57 deletions(-) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 1e09eba39e8..b7e1a784de0 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -331,6 +331,9 @@ let test_reactive_join_alloc_n n = emit_left add_wave done; assert (Reactive.length joined = n); + ReactiveWave.destroy remove_wave; + ReactiveWave.destroy add_wave; + Reactive.destroy_graph (); words_since () / iters let test_reactive_join_alloc () = @@ -390,6 +393,10 @@ let test_reactive_fixpoint_alloc_n n = emit_root add_wave done; assert (Reactive.length reachable = n); + ReactiveWave.destroy edge_wave; + ReactiveWave.destroy remove_wave; + ReactiveWave.destroy add_wave; + Reactive.destroy_graph (); words_since () / iters let test_reactive_fixpoint_alloc () = @@ -503,6 +510,9 @@ let test_reactive_flatmap_alloc_n n = emit_src add_wave done; assert (Reactive.length derived = n); + ReactiveWave.destroy remove_wave; + ReactiveWave.destroy add_wave; + Reactive.destroy_graph (); words_since () / iters let test_reactive_flatmap_alloc () = diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index e11a6f2776c..c99cdc79c2c 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -136,7 +136,7 @@ let length (collection : t) = ReactiveFileCollection.length collection Returns (path, file_data option) suitable for ReactiveMerge. *) let to_file_data_collection (collection : t) : (string, DceFileProcessing.file_data option) Reactive.t = - Reactive.flatMap ~name:"file_data_collection" + Reactive.FlatMap.create ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) ~f:(fun path result_opt emit -> match result_opt with diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index 28ca500f147..87e3d50a38e 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -14,7 +14,7 @@ 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 + Reactive.FlatMap.create ~name:"decl_refs.decls_by_file" decls ~f:(fun pos decl emit -> emit pos.Lexing.pos_fname [(pos, decl)]) ~merge:( @ ) () in @@ -28,7 +28,7 @@ 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_mb emit -> @@ -42,7 +42,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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 + Reactive.Join.create ~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_mb emit -> if ReactiveMaybe.is_some decls_mb then @@ -57,7 +58,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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_mb emit -> let refs = @@ -69,7 +70,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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_mb emit -> let refs = @@ -81,7 +82,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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_mb emit -> let type_targets = diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index 1d0b3a3fccc..0a612b8a430 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -26,7 +26,7 @@ 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 + Reactive.FlatMap.create ~name:"exc_refs.exception_decls" decls ~f:(fun _pos (decl : Decl.t) emit -> match decl.Decl.declKind with | Exception -> @@ -44,7 +44,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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_mb emit -> if ReactiveMaybe.is_some loc_to_mb then @@ -57,7 +58,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 3: Create refs_from direction by inverting *) let resolved_refs_from = - Reactive.flatMap ~name:"exc_refs.resolved_refs_from" resolved_refs + Reactive.FlatMap.create ~name:"exc_refs.resolved_refs_from" resolved_refs ~f:(fun posTo posFromSet emit -> PosSet.iter (fun posFrom -> emit posFrom (PosSet.singleton posTo)) diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index e380978e08f..a50e02d654e 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -19,13 +19,14 @@ 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:PosSet.union () 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 + Reactive.Union.create ~name:"liveness.type_refs_from" merged.type_refs_from merged.type_deps.all_type_refs_from ~merge:PosSet.union () in @@ -36,7 +37,7 @@ let create ~(merged : ReactiveMerge.t) : t = (* 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 + Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index ~f:(fun pos (value_targets, type_targets) emit -> let all_targets = PosSet.union value_targets type_targets in emit pos (PosSet.elements all_targets)) @@ -55,7 +56,8 @@ 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_mb emit -> if not (ReactiveMaybe.is_some decl_mb) then @@ -66,7 +68,8 @@ let create ~(merged : ReactiveMerge.t) : t = 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_mb emit -> if not (ReactiveMaybe.is_some decl_mb) then @@ -77,15 +80,15 @@ let create ~(merged : ReactiveMerge.t) : t = in let externally_referenced : (Lexing.position, unit) Reactive.t = - Reactive.union ~name:"liveness.externally_referenced" external_value_refs - external_type_refs + Reactive.Union.create ~name:"liveness.externally_referenced" + external_value_refs external_type_refs ~merge:(fun () () -> ()) () 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_mb emit -> if ReactiveMaybe.is_some ann_mb then @@ -98,7 +101,7 @@ let create ~(merged : ReactiveMerge.t) : t = (* 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 () () -> ()) () @@ -106,7 +109,7 @@ let create ~(merged : ReactiveMerge.t) : t = (* 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/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index 0be82271f91..f5e485af41a 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -25,7 +25,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : t = (* Declarations: (pos, Decl.t) with last-write-wins *) let decls = - Reactive.flatMap ~name:"decls" source + Reactive.FlatMap.create ~name:"decls" source ~f:(fun _path file_data_opt emit -> match file_data_opt with | None -> () @@ -37,7 +37,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Annotations: (pos, annotated_as) with last-write-wins *) let annotations = - Reactive.flatMap ~name:"annotations" source + Reactive.FlatMap.create ~name:"annotations" source ~f:(fun _path file_data_opt emit -> match file_data_opt with | None -> () @@ -50,7 +50,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Value refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let value_refs_from = - Reactive.flatMap ~name:"value_refs_from" source + Reactive.FlatMap.create ~name:"value_refs_from" source ~f:(fun _path file_data_opt emit -> match file_data_opt with | None -> () @@ -63,7 +63,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Type refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let type_refs_from = - Reactive.flatMap ~name:"type_refs_from" source + Reactive.FlatMap.create ~name:"type_refs_from" source ~f:(fun _path file_data_opt emit -> match file_data_opt with | None -> () @@ -76,7 +76,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Cross-file items: (path, CrossFileItems.t) with merge by concatenation *) let cross_file_items = - Reactive.flatMap ~name:"cross_file_items" source + Reactive.FlatMap.create ~name:"cross_file_items" source ~f:(fun path file_data_opt emit -> match file_data_opt with | None -> () @@ -97,7 +97,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* File deps map: (from_file, FileSet of to_files) with FileSet.union merge *) let file_deps_map = - Reactive.flatMap ~name:"file_deps_map" source + Reactive.FlatMap.create ~name:"file_deps_map" source ~f:(fun _path file_data_opt emit -> match file_data_opt with | None -> () @@ -109,7 +109,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Files set: (source_path, ()) - just track which source files exist *) let files = - Reactive.flatMap ~name:"files" source + Reactive.FlatMap.create ~name:"files" source ~f:(fun _cmt_path file_data_opt emit -> match file_data_opt with | None -> () @@ -124,7 +124,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Extract exception_refs from cross_file_items for ReactiveExceptionRefs *) let exception_refs_collection = - Reactive.flatMap ~name:"exception_refs_collection" cross_file_items + Reactive.FlatMap.create ~name:"exception_refs_collection" cross_file_items ~f:(fun _path items emit -> items.CrossFileItems.exception_refs |> List.iter (fun (r : CrossFileItems.exception_ref) -> diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index 818ce0e2567..2bb909a3edb 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -55,7 +55,7 @@ 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_mb emit -> if not (ReactiveMaybe.is_some live_mb) then emit pos decl) @@ -64,7 +64,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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_mb emit -> if ReactiveMaybe.is_some live_mb then emit pos decl) @@ -75,13 +75,13 @@ 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 + Reactive.FlatMap.create ~name:"solver.dead_modules_empty" dead_decls ~f:(fun _k _v _emit -> ()) () 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 + Reactive.FlatMap.create ~name:"solver.modules_with_dead" dead_decls ~f:(fun _pos decl emit -> emit (decl_module_name decl) (decl.moduleLoc, decl.pos.Lexing.pos_fname)) @@ -90,12 +90,12 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) in (* modules_with_live: (moduleName, ()) for each module with live decls *) let modules_with_live = - Reactive.flatMap ~name:"solver.modules_with_live" live_decls + Reactive.FlatMap.create ~name:"solver.modules_with_live" live_decls ~f:(fun _pos decl emit -> emit (decl_module_name decl) ()) () 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_mb emit -> @@ -106,7 +106,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Reactive per-file grouping of dead declarations *) let dead_decls_by_file = - Reactive.flatMap ~name:"solver.dead_decls_by_file" dead_decls + Reactive.FlatMap.create ~name:"solver.dead_decls_by_file" dead_decls ~f:(fun _pos decl emit -> emit decl.pos.Lexing.pos_fname [decl]) ~merge:(fun decls1 decls2 -> decls1 @ decls2) () @@ -164,19 +164,20 @@ 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 + Reactive.FlatMap.create ~name:"solver.issues_by_file" dead_decls_by_file ~f:(fun file decls emit -> emit file (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 + Reactive.FlatMap.create ~name:"solver.refs_token" refs_from ~f:(fun _posFrom _targets emit -> emit () ()) ~merge:(fun _ _ -> ()) () in - Reactive.join ~name:"solver.issues_by_file" dead_decls_by_file refs_token + Reactive.Join.create ~name:"solver.issues_by_file" dead_decls_by_file + refs_token ~key_of:(fun _file _decls -> ()) ~f:(fun file decls _token_mb emit -> emit file (issues_for_file file decls)) @@ -185,7 +186,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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_mb emit -> if ReactiveMaybe.is_some ann_mb then @@ -197,7 +199,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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 + Reactive.FlatMap.create ~name:"solver.modules_with_reported" issues_by_file ~f:(fun _file (_issues, modules_list) emit -> List.iter (fun m -> emit m ()) modules_list) () @@ -205,7 +207,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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_mb emit -> diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 30f68183926..7baf2e6bc1f 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -49,7 +49,7 @@ 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 + Reactive.FlatMap.create ~name:"type_deps.decl_by_path" decls ~f:(fun _pos decl emit -> match decl_to_info decl with | Some info -> emit info.path [info] @@ -59,7 +59,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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 + Reactive.FlatMap.create ~name:"type_deps.same_path_refs" decl_by_path ~f:(fun _path decls emit -> match decls with | [] | [_] -> () @@ -80,7 +80,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* 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 + Reactive.FlatMap.create ~name:"type_deps.impl_decls" decls ~f:(fun _pos decl emit -> match decl_to_info decl with | Some info when not info.is_interface -> ( @@ -101,7 +101,8 @@ 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 + Reactive.Join.create ~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_mb emit -> if ReactiveMaybe.is_some intf_decls_mb then @@ -118,7 +119,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Second join for path2 fallback *) let impl_needing_path2 = - Reactive.join ~name:"type_deps.impl_needing_path2" impl_decls decl_by_path + Reactive.Join.create ~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_mb emit -> let found = @@ -133,8 +135,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) in let impl_to_intf_refs_path2 = - Reactive.join ~name:"type_deps.impl_to_intf_refs_path2" impl_needing_path2 - decl_by_path + Reactive.Join.create ~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_mb emit -> if ReactiveMaybe.is_some intf_decls_mb then @@ -154,7 +156,7 @@ 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 + Reactive.FlatMap.create ~name:"type_deps.intf_decls" decls ~f:(fun _pos decl emit -> match decl_to_info decl with | Some info when info.is_interface -> ( @@ -170,7 +172,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) in let intf_to_impl_refs = - Reactive.join ~name:"type_deps.intf_to_impl_refs" intf_decls decl_by_path + Reactive.Join.create ~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_mb emit -> if ReactiveMaybe.is_some impl_decls_mb then @@ -213,18 +216,19 @@ 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:PosSet.union () in let u2 = - Reactive.union ~name:"type_deps.u2" u1 impl_to_intf_refs_path2 + Reactive.Union.create ~name:"type_deps.u2" u1 impl_to_intf_refs_path2 ~merge:PosSet.union () 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:PosSet.union () in (* Invert the combined refs_to to refs_from *) - Reactive.flatMap ~name:"type_deps.all_type_refs_from" combined_refs_to + Reactive.FlatMap.create ~name:"type_deps.all_type_refs_from" + combined_refs_to ~f:(fun posTo posFromSet emit -> PosSet.iter (fun posFrom -> emit posFrom (PosSet.singleton posTo)) From 3f2258079006bbca141b9b905fb3d608f1a0539b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 6 Mar 2026 21:30:48 +0100 Subject: [PATCH 17/54] analysis/reactive: move flat combinator maps off heap --- analysis/reactive/src/ReactiveAllocator.ml | 26 +++ analysis/reactive/src/ReactiveAllocator.mli | 38 +++++ analysis/reactive/src/ReactiveFlatMap.ml | 74 +++++---- analysis/reactive/src/ReactiveJoin.ml | 138 ++++++++++------ analysis/reactive/src/ReactiveMap.ml | 161 +++++++++++++++++++ analysis/reactive/src/ReactiveMap.mli | 33 ++++ analysis/reactive/src/ReactiveSet.ml | 104 ++++++++++++ analysis/reactive/src/ReactiveSet.mli | 26 +++ analysis/reactive/src/ReactiveUnion.ml | 169 +++++++++++++------- 9 files changed, 629 insertions(+), 140 deletions(-) create mode 100644 analysis/reactive/src/ReactiveMap.ml create mode 100644 analysis/reactive/src/ReactiveMap.mli create mode 100644 analysis/reactive/src/ReactiveSet.ml create mode 100644 analysis/reactive/src/ReactiveSet.mli diff --git a/analysis/reactive/src/ReactiveAllocator.ml b/analysis/reactive/src/ReactiveAllocator.ml index 929aae8d3d6..fe4395d1dda 100644 --- a/analysis/reactive/src/ReactiveAllocator.ml +++ b/analysis/reactive/src/ReactiveAllocator.ml @@ -76,3 +76,29 @@ module Block = struct invalid_arg "ReactiveAllocator.Block.blit"; blit_unsafe src src_pos dst dst_pos len end + +module Block2 = struct + type ('a, 'x, 'y) t = Block.t + + let header_slots = 2 + + let create ~capacity ~x0 ~y0 = + let t = Block.create ~capacity:(capacity + header_slots) in + Block.set t 0 (unsafe_to_offheap x0); + Block.set t 1 (unsafe_to_offheap 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 = unsafe_from_offheap (Block.get t 0) + let set0 t x = Block.set t 0 (unsafe_to_offheap x) + let get1 t = unsafe_from_offheap (Block.get t 1) + let set1 t y = Block.set t 1 (unsafe_to_offheap 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/ReactiveAllocator.mli b/analysis/reactive/src/ReactiveAllocator.mli index 4c41107ed7a..fd0493a78c4 100644 --- a/analysis/reactive/src/ReactiveAllocator.mli +++ b/analysis/reactive/src/ReactiveAllocator.mli @@ -64,6 +64,44 @@ module Block : sig (** 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 an off-heap 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 offheap + (** Read a data slot. *) + + val set : ('a, 'x, 'y) t -> int -> 'a offheap -> 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. *) diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 16dfa4d86b0..48b2dfce993 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -1,9 +1,4 @@ -(** Zero-allocation (steady-state) flatMap state and processing logic. - - Uses ReactiveHash for persistent state and scratch tables. - After steady-state capacity is reached, the per-process overhead - is zero allocations (emit-callback API, ReactiveHash.Set for - provenance, iter_with for all iterations). *) +(** Zero-allocation (steady-state) flatMap state and processing logic. *) type ('k1, 'v1, 'k2, 'v2) t = { f: 'k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit; @@ -11,10 +6,10 @@ type ('k1, 'v1, 'k2, 'v2) t = { (* Persistent state *) provenance: ('k1, 'k2) ReactivePoolMapSet.t; contributions: ('k2, 'k1, 'v2) ReactivePoolMapMap.t; - target: ('k2, 'v2) ReactiveHash.Map.t; + target: ('k2, 'v2) ReactiveMap.t; (* Scratch — allocated once, cleared per process() *) - scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveHash.Map.t; - affected: 'k2 ReactiveHash.Set.t; + scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveMap.t; + affected: 'k2 ReactiveSet.t; (* Pre-allocated output buffer *) output_wave: ('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t; (* Emit callback state — allocated once, reused per entry *) @@ -40,13 +35,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveHash.Set.add t.affected k2 + ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k2) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveHash.Map.replace t.target k2 v2 + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k2) + (ReactiveAllocator.unsafe_to_offheap v2) let create ~f ~merge = let rec t = @@ -55,9 +52,9 @@ let create ~f ~merge = merge; provenance = ReactivePoolMapSet.create ~capacity:128; contributions = ReactivePoolMapMap.create ~capacity:128; - target = ReactiveHash.Map.create (); - scratch = ReactiveHash.Map.create (); - affected = ReactiveHash.Set.create (); + target = ReactiveMap.create (); + scratch = ReactiveMap.create (); + affected = ReactiveSet.create (); output_wave = ReactiveWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k2 v2 -> add_single_contribution t k2 v2); @@ -76,20 +73,21 @@ let create ~f ~merge = in t -let destroy t = ReactiveWave.destroy t.output_wave +let destroy t = + ReactiveMap.destroy t.target; + ReactiveMap.destroy t.scratch; + ReactiveSet.destroy t.affected; + ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -let push t k v_opt = - ReactiveHash.Map.replace t.scratch - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v_opt) +let push t k v_opt = ReactiveMap.replace t.scratch k v_opt (* Remove one contribution key during remove_source iteration *) let remove_one_contribution (t : (_, _, _, _) t) k2 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 t.current_k1; - ReactiveHash.Set.add t.affected k2 + ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k2) let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; @@ -103,22 +101,27 @@ let merge_one_contribution (t : (_, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _) t) k2 = + let k2 = ReactiveAllocator.unsafe_from_offheap k2 in if ReactivePoolMapMap.inner_cardinal t.contributions k2 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; - ReactiveHash.Map.replace t.target k2 t.merge_acc; + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k2) + (ReactiveAllocator.unsafe_to_offheap t.merge_acc); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k2) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some t.merge_acc))) else ( - ReactiveHash.Map.remove t.target k2; + ReactiveMap.remove t.target (ReactiveAllocator.unsafe_to_offheap k2); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k2) ReactiveMaybe.none_offheap) (* Single-pass process + count for scratch *) let process_scratch_entry (t : (_, _, _, _) t) k1 mv = + let k1 = ReactiveAllocator.unsafe_from_offheap k1 in + let mv = ReactiveAllocator.unsafe_from_offheap mv in t.result.entries_received <- t.result.entries_received + 1; remove_source t k1; if ReactiveMaybe.is_some mv then ( @@ -141,13 +144,13 @@ let process (t : (_, _, _, _) t) = r.adds_emitted <- 0; r.removes_emitted <- 0; - ReactiveHash.Set.clear t.affected; + ReactiveSet.clear t.affected; ReactiveWave.clear t.output_wave; - ReactiveHash.Map.iter_with process_scratch_entry t t.scratch; - ReactiveHash.Map.clear t.scratch; + ReactiveMap.iter_with process_scratch_entry t t.scratch; + ReactiveMap.clear t.scratch; - ReactiveHash.Set.iter_with recompute_target t t.affected; + ReactiveSet.iter_with recompute_target t t.affected; let num_entries = ReactiveWave.count t.output_wave in r.entries_emitted <- num_entries; @@ -159,6 +162,19 @@ let init_entry (t : (_, _, _, _) t) k1 v1 = t.current_k1 <- k1; t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) -let iter_target f t = ReactiveHash.Map.iter f t.target -let find_target t k = ReactiveHash.Map.find_maybe t.target k -let target_length t = ReactiveHash.Map.cardinal t.target +let iter_target f t = + ReactiveMap.iter + (fun k v -> + f + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v)) + t.target + +let find_target t k = + ReactiveMap.find_maybe t.target (ReactiveAllocator.unsafe_to_offheap k) + |> ReactiveMaybe.to_option + |> function + | Some v -> ReactiveMaybe.some (ReactiveAllocator.unsafe_from_offheap v) + | None -> ReactiveMaybe.none + +let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index d634a6617cf..9d9b862e3e5 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -1,9 +1,4 @@ -(** Zero-allocation (steady-state) join state and processing logic. - - Uses ReactiveHash for persistent state and scratch tables. - After steady-state capacity is reached, the per-process overhead - is zero allocations (emit-callback API, ReactiveHash.Set for - provenance/reverse-index, iter_with for all iterations). *) +(** Zero-allocation (steady-state) join state and processing logic. *) type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { key_of: 'k1 -> 'v1 -> 'k2; @@ -11,16 +6,16 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { merge: 'v3 -> 'v3 -> 'v3; right_get: 'k2 -> 'v2 ReactiveMaybe.t; (* Persistent state *) - left_entries: ('k1, 'v1) ReactiveHash.Map.t; + left_entries: ('k1, 'v1) ReactiveMap.t; provenance: ('k1, 'k3) ReactivePoolMapSet.t; contributions: ('k3, 'k1, 'v3) ReactivePoolMapMap.t; - target: ('k3, 'v3) ReactiveHash.Map.t; - left_to_right_key: ('k1, 'k2) ReactiveHash.Map.t; + target: ('k3, 'v3) ReactiveMap.t; + left_to_right_key: ('k1, 'k2) ReactiveMap.t; right_key_to_left_keys: ('k2, 'k1) ReactivePoolMapSet.t; (* Scratch — allocated once, cleared per process() *) - left_scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveHash.Map.t; - right_scratch: ('k2, 'v2 ReactiveMaybe.t) ReactiveHash.Map.t; - affected: 'k3 ReactiveHash.Set.t; + left_scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveMap.t; + right_scratch: ('k2, 'v2 ReactiveMaybe.t) ReactiveMap.t; + affected: 'k3 ReactiveSet.t; (* Pre-allocated output buffer *) output_wave: ('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t; (* Emit callback state — allocated once, reused per entry *) @@ -46,13 +41,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveHash.Set.add t.affected k3 + ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k3) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveHash.Map.replace t.target k3 v3 + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k3) + (ReactiveAllocator.unsafe_to_offheap v3) let create ~key_of ~f ~merge ~right_get = let rec t = @@ -61,15 +58,15 @@ let create ~key_of ~f ~merge ~right_get = f; merge; right_get; - left_entries = ReactiveHash.Map.create (); + left_entries = ReactiveMap.create (); provenance = ReactivePoolMapSet.create ~capacity:128; contributions = ReactivePoolMapMap.create ~capacity:128; - target = ReactiveHash.Map.create (); - left_to_right_key = ReactiveHash.Map.create (); + target = ReactiveMap.create (); + left_to_right_key = ReactiveMap.create (); right_key_to_left_keys = ReactivePoolMapSet.create ~capacity:128; - left_scratch = ReactiveHash.Map.create (); - right_scratch = ReactiveHash.Map.create (); - affected = ReactiveHash.Set.create (); + left_scratch = ReactiveMap.create (); + right_scratch = ReactiveMap.create (); + affected = ReactiveSet.create (); output_wave = ReactiveWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k3 v3 -> add_single_contribution t k3 v3); @@ -88,35 +85,42 @@ let create ~key_of ~f ~merge ~right_get = in t -let destroy t = ReactiveWave.destroy t.output_wave +let destroy t = + ReactiveMap.destroy t.left_entries; + ReactiveMap.destroy t.target; + ReactiveMap.destroy t.left_to_right_key; + ReactiveMap.destroy t.left_scratch; + ReactiveMap.destroy t.right_scratch; + ReactiveSet.destroy t.affected; + ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -let push_left t k v_opt = - ReactiveHash.Map.replace t.left_scratch - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v_opt) +let push_left t k v_opt = ReactiveMap.replace t.left_scratch k v_opt -let push_right t k v_opt = - ReactiveHash.Map.replace t.right_scratch - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v_opt) +let push_right t k v_opt = ReactiveMap.replace t.right_scratch k v_opt (* Remove one contribution key during remove_left_contributions iteration *) let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 t.current_k1; - ReactiveHash.Set.add t.affected k3 + ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k3) let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; ReactivePoolMapSet.drain_key t.provenance k1 t remove_one_contribution_key let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = - let mb = ReactiveHash.Map.find_maybe t.left_to_right_key k1 in + let mb = + ReactiveMap.find_maybe t.left_to_right_key + (ReactiveAllocator.unsafe_to_offheap k1) + in if ReactiveMaybe.is_some mb then ( - let old_k2 = ReactiveMaybe.unsafe_get mb in - ReactiveHash.Map.remove t.left_to_right_key k1; + let old_k2 = + ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get mb) + in + ReactiveMap.remove t.left_to_right_key + (ReactiveAllocator.unsafe_to_offheap k1); ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys old_k2 k1) @@ -124,14 +128,16 @@ 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 - ReactiveHash.Map.replace t.left_to_right_key k1 k2; + ReactiveMap.replace t.left_to_right_key + (ReactiveAllocator.unsafe_to_offheap k1) + (ReactiveAllocator.unsafe_to_offheap k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; t.f k1 v1 right_val t.emit_fn let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = - ReactiveHash.Map.remove t.left_entries k1; + ReactiveMap.remove t.left_entries (ReactiveAllocator.unsafe_to_offheap k1); remove_left_contributions t k1; unlink_right_key t k1 @@ -143,27 +149,34 @@ let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _, _, _) t) k3 = + let k3 = ReactiveAllocator.unsafe_from_offheap k3 in if ReactivePoolMapMap.inner_cardinal t.contributions k3 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; - ReactiveHash.Map.replace t.target k3 t.merge_acc; + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k3) + (ReactiveAllocator.unsafe_to_offheap t.merge_acc); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k3) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some t.merge_acc))) else ( - ReactiveHash.Map.remove t.target k3; + ReactiveMap.remove t.target (ReactiveAllocator.unsafe_to_offheap k3); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k3) ReactiveMaybe.none_offheap) (* Single-pass process + count for left scratch *) let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = + let k1 = ReactiveAllocator.unsafe_from_offheap k1 in + let mv = ReactiveAllocator.unsafe_from_offheap mv in t.result.entries_received <- t.result.entries_received + 1; if ReactiveMaybe.is_some mv then ( t.result.adds_received <- t.result.adds_received + 1; let v1 = ReactiveMaybe.unsafe_get mv in - ReactiveHash.Map.replace t.left_entries k1 v1; + ReactiveMap.replace t.left_entries + (ReactiveAllocator.unsafe_to_offheap k1) + (ReactiveAllocator.unsafe_to_offheap v1); process_left_entry t k1 v1) else ( t.result.removes_received <- t.result.removes_received + 1; @@ -171,12 +184,18 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = - let mb = ReactiveHash.Map.find_maybe t.left_entries k1 in + let mb = + ReactiveMap.find_maybe t.left_entries + (ReactiveAllocator.unsafe_to_offheap k1) + in if ReactiveMaybe.is_some mb then - process_left_entry t k1 (ReactiveMaybe.unsafe_get mb) + process_left_entry t k1 + (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get mb)) (* Single-pass process + count for right scratch *) let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = + let k2 = ReactiveAllocator.unsafe_from_offheap k2 in + let _mv = ReactiveAllocator.unsafe_from_offheap _mv in t.result.entries_received <- t.result.entries_received + 1; if ReactiveMaybe.is_some _mv then t.result.adds_received <- t.result.adds_received + 1 @@ -199,16 +218,16 @@ let process (t : (_, _, _, _, _, _) t) = r.adds_emitted <- 0; r.removes_emitted <- 0; - ReactiveHash.Set.clear t.affected; + ReactiveSet.clear t.affected; ReactiveWave.clear t.output_wave; - ReactiveHash.Map.iter_with process_left_scratch_entry t t.left_scratch; - ReactiveHash.Map.iter_with process_right_scratch_entry t t.right_scratch; + ReactiveMap.iter_with process_left_scratch_entry t t.left_scratch; + ReactiveMap.iter_with process_right_scratch_entry t t.right_scratch; - ReactiveHash.Map.clear t.left_scratch; - ReactiveHash.Map.clear t.right_scratch; + ReactiveMap.clear t.left_scratch; + ReactiveMap.clear t.right_scratch; - ReactiveHash.Set.iter_with recompute_target t t.affected; + ReactiveSet.iter_with recompute_target t t.affected; let num_entries = ReactiveWave.count t.output_wave in r.entries_emitted <- num_entries; @@ -217,14 +236,31 @@ let process (t : (_, _, _, _, _, _) t) = r let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = - ReactiveHash.Map.replace t.left_entries k1 v1; + ReactiveMap.replace t.left_entries + (ReactiveAllocator.unsafe_to_offheap k1) + (ReactiveAllocator.unsafe_to_offheap v1); let k2 = t.key_of k1 v1 in - ReactiveHash.Map.replace t.left_to_right_key k1 k2; + ReactiveMap.replace t.left_to_right_key + (ReactiveAllocator.unsafe_to_offheap k1) + (ReactiveAllocator.unsafe_to_offheap k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; t.f k1 v1 right_val (fun k3 v3 -> add_single_contribution_init t k3 v3) -let iter_target f t = ReactiveHash.Map.iter f t.target -let find_target t k = ReactiveHash.Map.find_maybe t.target k -let target_length t = ReactiveHash.Map.cardinal t.target +let iter_target f t = + ReactiveMap.iter + (fun k v -> + f + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v)) + t.target + +let find_target t k = + ReactiveMap.find_maybe t.target (ReactiveAllocator.unsafe_to_offheap k) + |> ReactiveMaybe.to_option + |> function + | Some v -> ReactiveMaybe.some (ReactiveAllocator.unsafe_from_offheap v) + | None -> ReactiveMaybe.none + +let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/ReactiveMap.ml new file mode 100644 index 00000000000..0789af3a958 --- /dev/null +++ b/analysis/reactive/src/ReactiveMap.ml @@ -0,0 +1,161 @@ +type ('k, 'v) t = { + keys: ('k, int, int) ReactiveAllocator.Block2.t; + vals: ReactiveAllocator.Block.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 ReactiveAllocator.offheap = + Obj.magic empty_sentinel +let[@inline] tomb_slot () : 'a ReactiveAllocator.offheap = + Obj.magic tomb_sentinel + +let key_capacity t = ReactiveAllocator.Block2.capacity t.keys +let population t = ReactiveAllocator.Block2.get0 t.keys +let set_population t n = ReactiveAllocator.Block2.set0 t.keys n +let occupation t = ReactiveAllocator.Block2.get1 t.keys +let set_occupation t n = ReactiveAllocator.Block2.set1 t.keys n +let[@inline] mask t = key_capacity t - 1 + +let[@inline] start t x = + Hashtbl.hash (ReactiveAllocator.unsafe_from_offheap 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 key_capacity t - 1 do + ReactiveAllocator.Block2.set t.keys i (empty_slot ()) + done + +let create () = + let keys = + ReactiveAllocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 + in + let vals = ReactiveAllocator.Block.create ~capacity:initial_capacity in + let t = {keys; vals} in + clear_keys t; + t + +let destroy t = + ReactiveAllocator.Block2.destroy t.keys; + ReactiveAllocator.Block.destroy t.vals + +let clear t = + set_population t 0; + set_occupation t 0; + clear_keys t + +let insert_absent t k v = + let empty : 'k ReactiveAllocator.offheap = empty_slot () in + let j = ref (start t k) in + while ReactiveAllocator.Block2.get t.keys !j != empty do + j := next t !j + done; + ReactiveAllocator.Block2.set t.keys !j k; + ReactiveAllocator.Block.set t.vals !j v + +let resize t new_cap = + let old_cap = key_capacity t in + let old_keys = + ReactiveAllocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:0 + in + let old_vals = ReactiveAllocator.Block.create ~capacity:old_cap in + ReactiveAllocator.Block2.blit ~src:t.keys ~src_pos:0 ~dst:old_keys ~dst_pos:0 + ~len:old_cap; + ReactiveAllocator.Block.blit ~src:t.vals ~src_pos:0 ~dst:old_vals ~dst_pos:0 + ~len:old_cap; + ReactiveAllocator.Block2.resize t.keys ~capacity:new_cap; + ReactiveAllocator.Block.resize t.vals ~capacity:new_cap; + set_population t 0; + set_occupation t 0; + clear_keys t; + for i = 0 to old_cap - 1 do + let k = ReactiveAllocator.Block2.get old_keys i in + if k != empty_slot () && k != tomb_slot () then ( + insert_absent t k (ReactiveAllocator.Block.get old_vals i); + set_population t (population t + 1); + set_occupation t (occupation t + 1)) + done; + ReactiveAllocator.Block2.destroy old_keys; + ReactiveAllocator.Block.destroy old_vals + +let maybe_grow_before_insert t = + let cap = key_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 ReactiveAllocator.offheap = empty_slot () in + let tomb : 'k ReactiveAllocator.offheap = 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 = ReactiveAllocator.Block2.get t.keys !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); + ReactiveAllocator.Block2.set t.keys dst k; + ReactiveAllocator.Block.set t.vals 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 ( + ReactiveAllocator.Block.set t.vals !j v; + done_ := true) + else j := next t !j + done + +let remove t k = + let empty : 'k ReactiveAllocator.offheap = empty_slot () in + let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let j = ref (start t k) in + let done_ = ref false in + while not !done_ do + let current = ReactiveAllocator.Block2.get t.keys !j in + if current == empty then done_ := true + else if current == tomb then j := next t !j + else if current = k then ( + ReactiveAllocator.Block2.set t.keys !j tomb; + set_population t (population t - 1); + done_ := true) + else j := next t !j + done + +let find_maybe t k = + let empty : 'k ReactiveAllocator.offheap = empty_slot () in + let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let j = ref (start t k) in + let found = ref ReactiveMaybe.none in + let done_ = ref false in + while not !done_ do + let current = ReactiveAllocator.Block2.get t.keys !j in + if current == empty then done_ := true + else if current == tomb then j := next t !j + else if current = k then ( + found := ReactiveMaybe.some (ReactiveAllocator.Block.get t.vals !j); + done_ := true) + else j := next t !j + done; + !found + +let iter_with f arg t = + let empty : 'k ReactiveAllocator.offheap = empty_slot () in + let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + if population t > 0 then + for i = 0 to key_capacity t - 1 do + let k = ReactiveAllocator.Block2.get t.keys i in + if k != empty && k != tomb then + f arg k (ReactiveAllocator.Block.get t.vals 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/ReactiveMap.mli b/analysis/reactive/src/ReactiveMap.mli new file mode 100644 index 00000000000..84eb75880b9 --- /dev/null +++ b/analysis/reactive/src/ReactiveMap.mli @@ -0,0 +1,33 @@ +(** Off-heap 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 ReactiveAllocator.offheap -> + 'v ReactiveAllocator.offheap -> + unit + +val remove : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> unit + +val find_maybe : + ('k, 'v) t -> + 'k ReactiveAllocator.offheap -> + 'v ReactiveAllocator.offheap ReactiveMaybe.t + +val iter_with : + ('a -> 'k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> + 'a -> + ('k, 'v) t -> + unit + +val iter : + ('k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> + ('k, 'v) t -> + unit + +val cardinal : ('k, 'v) t -> int diff --git a/analysis/reactive/src/ReactiveSet.ml b/analysis/reactive/src/ReactiveSet.ml new file mode 100644 index 00000000000..f85d4e19478 --- /dev/null +++ b/analysis/reactive/src/ReactiveSet.ml @@ -0,0 +1,104 @@ +(* Representation of ['a t]: + + - ['a t] is [('a, int, int) ReactiveAllocator.Block2.t]. + - Header slot [0]: population, exposed as [int]. + - Header slot [1]: index mask, exposed as [int]. + - Data slots: keys, stored as ['a ReactiveAllocator.offheap]. + + The backing block lives off-heap. Elements are ordinary OCaml values whose + storage invariant has already been established before insertion. + + Empty data slots contain a distinguished sentinel value. All other data + slots contain real set elements. *) + +type 'a t = ('a, int, int) ReactiveAllocator.Block2.t + +let initial_capacity = 8 +let max_load_percent = 82 + +let sentinel : Obj.t = Obj.repr (Array.make 257 0) +let[@inline] empty_sentinel = + fun () -> (Obj.magic sentinel : 'a ReactiveAllocator.offheap) + +let slot_capacity = ReactiveAllocator.Block2.capacity +let population = ReactiveAllocator.Block2.get0 +let set_population = ReactiveAllocator.Block2.set0 +let mask = ReactiveAllocator.Block2.get1 +let set_mask = ReactiveAllocator.Block2.set1 + +let[@inline] start t x = + Hashtbl.hash (ReactiveAllocator.unsafe_from_offheap 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 + ReactiveAllocator.Block2.set t i (empty_sentinel ()) + done + +let create () = + let t = + ReactiveAllocator.Block2.create ~capacity:initial_capacity ~x0:0 + ~y0:(initial_capacity - 1) + in + clear_slots t; + t + +let destroy = ReactiveAllocator.Block2.destroy + +let clear t = + set_population t 0; + clear_slots t + +let add_absent_key (type a) (t : a t) (x : a ReactiveAllocator.offheap) = + let j = ref (start t x) in + while ReactiveAllocator.Block2.get t !j != empty_sentinel () do + j := next t !j + done; + ReactiveAllocator.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 = + ReactiveAllocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:(old_cap - 1) + in + ReactiveAllocator.Block2.blit ~src:t ~src_pos:0 ~dst:old_keys ~dst_pos:0 + ~len:old_cap; + ReactiveAllocator.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 = ReactiveAllocator.Block2.get old_keys i in + if x != empty_sentinel () then add_absent_key t x + done; + ReactiveAllocator.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 ReactiveAllocator.offheap) = + maybe_grow_before_add t; + let j = ref (start t x) in + let found = ref false in + while not !found do + let current = ReactiveAllocator.Block2.get t !j in + if current == empty_sentinel () then ( + ReactiveAllocator.Block2.set t !j x; + set_population t (population t + 1); + found := true) + else if current = x then found := true + else j := next t !j + done + +let iter_with (type a k) (f : a -> k ReactiveAllocator.offheap -> unit) + (arg : a) (t : k t) = + if population t > 0 then + for i = 0 to slot_capacity t - 1 do + let x = ReactiveAllocator.Block2.get t i in + if x != empty_sentinel () then f arg x + done + +let cardinal = population diff --git a/analysis/reactive/src/ReactiveSet.mli b/analysis/reactive/src/ReactiveSet.mli new file mode 100644 index 00000000000..c912db880cd --- /dev/null +++ b/analysis/reactive/src/ReactiveSet.mli @@ -0,0 +1,26 @@ +(** Off-heap mutable sets for reactive internals. + + Elements are ordinary OCaml values. The set's backing storage lives in the + custom allocator via {!ReactiveAllocator.Block2}. *) + +type 'a t + +val create : unit -> 'a t +(** Create an empty set. *) + +val destroy : 'a t -> unit +(** Release the set's owned off-heap 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 ReactiveAllocator.offheap -> unit +(** Add an element to the set. Re-adding an existing element is a no-op. *) + +val iter_with : + ('b -> 'a ReactiveAllocator.offheap -> unit) -> 'b -> 'a t -> unit +(** [iter_with f arg t] calls [f arg x] for each element. *) + +val cardinal : 'a t -> int +(** Number of elements currently stored. *) diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index 9db67b5b148..bc479cec7ec 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -1,17 +1,13 @@ -(** Zero-allocation union state and processing logic. - - Uses ReactiveHash (Hachis-backed) tables for all internal state. - After steady-state capacity is reached, [process] performs zero - heap allocation. *) +(** Zero-allocation union state and processing logic. *) type ('k, 'v) t = { merge: 'v -> 'v -> 'v; - left_values: ('k, 'v) ReactiveHash.Map.t; - right_values: ('k, 'v) ReactiveHash.Map.t; - target: ('k, 'v) ReactiveHash.Map.t; - left_scratch: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; - right_scratch: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; - affected: 'k ReactiveHash.Set.t; + left_values: ('k, 'v) ReactiveMap.t; + right_values: ('k, 'v) ReactiveMap.t; + target: ('k, 'v) ReactiveMap.t; + left_scratch: ('k, 'v ReactiveMaybe.t) ReactiveMap.t; + right_scratch: ('k, 'v ReactiveMaybe.t) ReactiveMap.t; + affected: 'k ReactiveSet.t; output_wave: ('k, 'v ReactiveMaybe.t) ReactiveWave.t; result: process_result; } @@ -28,12 +24,12 @@ and process_result = { let create ~merge = { merge; - left_values = ReactiveHash.Map.create (); - right_values = ReactiveHash.Map.create (); - target = ReactiveHash.Map.create (); - left_scratch = ReactiveHash.Map.create (); - right_scratch = ReactiveHash.Map.create (); - affected = ReactiveHash.Set.create (); + left_values = ReactiveMap.create (); + right_values = ReactiveMap.create (); + target = ReactiveMap.create (); + left_scratch = ReactiveMap.create (); + right_scratch = ReactiveMap.create (); + affected = ReactiveSet.create (); output_wave = ReactiveWave.create (); result = { @@ -46,73 +42,100 @@ let create ~merge = }; } -let destroy t = ReactiveWave.destroy t.output_wave +let destroy t = + ReactiveMap.destroy t.left_values; + ReactiveMap.destroy t.right_values; + ReactiveMap.destroy t.target; + ReactiveMap.destroy t.left_scratch; + ReactiveMap.destroy t.right_scratch; + ReactiveSet.destroy t.affected; + ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -let push_left t k mv = - ReactiveHash.Map.replace t.left_scratch - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap mv) +let push_left t k mv = ReactiveMap.replace t.left_scratch k mv -let push_right t k mv = - ReactiveHash.Map.replace t.right_scratch - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap mv) +let push_right t k mv = ReactiveMap.replace t.right_scratch k mv (* Module-level helpers for iter_with — avoid closure allocation *) -let apply_left_entry t k (mv : 'v ReactiveMaybe.t) = +let apply_left_entry t k mv = + let k = ReactiveAllocator.unsafe_from_offheap k in + let mv = ReactiveAllocator.unsafe_from_offheap mv in let r = t.result in r.entries_received <- r.entries_received + 1; if ReactiveMaybe.is_some mv then ( - ReactiveHash.Map.replace t.left_values k (ReactiveMaybe.unsafe_get mv); + ReactiveMap.replace t.left_values + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveHash.Map.remove t.left_values k; + ReactiveMap.remove t.left_values (ReactiveAllocator.unsafe_to_offheap k); r.removes_received <- r.removes_received + 1); - ReactiveHash.Set.add t.affected k + ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k) -let apply_right_entry t k (mv : 'v ReactiveMaybe.t) = +let apply_right_entry t k mv = + let k = ReactiveAllocator.unsafe_from_offheap k in + let mv = ReactiveAllocator.unsafe_from_offheap mv in let r = t.result in r.entries_received <- r.entries_received + 1; if ReactiveMaybe.is_some mv then ( - ReactiveHash.Map.replace t.right_values k (ReactiveMaybe.unsafe_get mv); + ReactiveMap.replace t.right_values + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveHash.Map.remove t.right_values k; + ReactiveMap.remove t.right_values (ReactiveAllocator.unsafe_to_offheap k); r.removes_received <- r.removes_received + 1); - ReactiveHash.Set.add t.affected k + ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k) let recompute_affected_entry t k = + let k = ReactiveAllocator.unsafe_from_offheap k in let r = t.result in - let lv = ReactiveHash.Map.find_maybe t.left_values k in - let rv = ReactiveHash.Map.find_maybe t.right_values k in + let lv = + ReactiveMap.find_maybe t.left_values (ReactiveAllocator.unsafe_to_offheap k) + in + let rv = + ReactiveMap.find_maybe t.right_values + (ReactiveAllocator.unsafe_to_offheap k) + in let has_left = ReactiveMaybe.is_some lv in let has_right = ReactiveMaybe.is_some rv in if has_left then ( if has_right then ( let merged = - t.merge (ReactiveMaybe.unsafe_get lv) (ReactiveMaybe.unsafe_get rv) + t.merge + (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get lv)) + (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get rv)) in - ReactiveHash.Map.replace t.target k merged; + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap merged); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some merged))) else - let v = ReactiveMaybe.unsafe_get lv in - ReactiveHash.Map.replace t.target k v; + let v = + ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get lv) + in + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap v); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) else if has_right then ( - let v = ReactiveMaybe.unsafe_get rv in - ReactiveHash.Map.replace t.target k v; + let v = + ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get rv) + in + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap v); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k) (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) else ( - ReactiveHash.Map.remove t.target k; + ReactiveMap.remove t.target (ReactiveAllocator.unsafe_to_offheap k); ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k) ReactiveMaybe.none_offheap); @@ -121,7 +144,7 @@ let recompute_affected_entry t k = else r.removes_emitted <- r.removes_emitted + 1 let process t = - ReactiveHash.Set.clear t.affected; + ReactiveSet.clear t.affected; let r = t.result in r.entries_received <- 0; r.adds_received <- 0; @@ -130,31 +153,57 @@ let process t = r.adds_emitted <- 0; r.removes_emitted <- 0; - ReactiveHash.Map.iter_with apply_left_entry t t.left_scratch; - ReactiveHash.Map.iter_with apply_right_entry t t.right_scratch; + ReactiveMap.iter_with apply_left_entry t t.left_scratch; + ReactiveMap.iter_with apply_right_entry t t.right_scratch; - ReactiveHash.Map.clear t.left_scratch; - ReactiveHash.Map.clear t.right_scratch; + ReactiveMap.clear t.left_scratch; + ReactiveMap.clear t.right_scratch; - if ReactiveHash.Set.cardinal t.affected > 0 then ( + if ReactiveSet.cardinal t.affected > 0 then ( ReactiveWave.clear t.output_wave; - ReactiveHash.Set.iter_with recompute_affected_entry t t.affected); + ReactiveSet.iter_with recompute_affected_entry t t.affected); r let init_left t k v = - ReactiveHash.Map.replace t.left_values k v; - ReactiveHash.Map.replace t.target k v + ReactiveMap.replace t.left_values + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap v); + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap v) let init_right t k v = - ReactiveHash.Map.replace t.right_values k v; - let lv = ReactiveHash.Map.find_maybe t.left_values k in + ReactiveMap.replace t.right_values + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap v); + let lv = + ReactiveMap.find_maybe t.left_values (ReactiveAllocator.unsafe_to_offheap k) + in let merged = - if ReactiveMaybe.is_some lv then t.merge (ReactiveMaybe.unsafe_get lv) v + if ReactiveMaybe.is_some lv then + t.merge + (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get lv)) + v else v in - ReactiveHash.Map.replace t.target k merged - -let iter_target f t = ReactiveHash.Map.iter f t.target -let find_target t k = ReactiveHash.Map.find_maybe t.target k -let target_length t = ReactiveHash.Map.cardinal t.target + ReactiveMap.replace t.target + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap merged) + +let iter_target f t = + ReactiveMap.iter + (fun k v -> + f + (ReactiveAllocator.unsafe_from_offheap k) + (ReactiveAllocator.unsafe_from_offheap v)) + t.target + +let find_target t k = + ReactiveMap.find_maybe t.target (ReactiveAllocator.unsafe_to_offheap k) + |> ReactiveMaybe.to_option + |> function + | Some v -> ReactiveMaybe.some (ReactiveAllocator.unsafe_from_offheap v) + | None -> ReactiveMaybe.none + +let target_length t = ReactiveMap.cardinal t.target From b33ef1d30542d2da76fc599d210ef14f68b32810 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 7 Mar 2026 08:36:05 +0100 Subject: [PATCH 18/54] analysis/reactive: move fixpoint unit state off heap --- analysis/reactive/src/ReactiveFixpoint.ml | 275 ++++++++++++---------- analysis/reactive/src/ReactiveMap.ml | 17 ++ analysis/reactive/src/ReactiveMap.mli | 2 + analysis/reactive/src/ReactiveSet.ml | 54 ++++- analysis/reactive/src/ReactiveSet.mli | 6 + 5 files changed, 227 insertions(+), 127 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 53549038e91..d205eb6e0e5 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -8,10 +8,8 @@ let rec list_iter_with f arg = function list_iter_with f arg rest (* Note on set representations: - [current] and [roots] stay as map-of-unit because they are updated as - first-class maps in multiple places. [pred_map] is represented by - [ReactivePoolMapSet] because its semantics are exactly map-of-set with - churn-safe remove+recycle behavior. *) + [pred_map] is represented by [ReactivePoolMapSet] because its semantics are + exactly map-of-set with churn-safe remove+recycle behavior. *) type 'k metrics_state = { mutable delete_queue_pops: int; @@ -21,27 +19,27 @@ type 'k metrics_state = { mutable rederive_edges_scanned: int; mutable expansion_queue_pops: int; mutable expansion_edges_scanned: int; - scratch_reachable: ('k, unit) ReactiveHash.Map.t; + scratch_reachable: 'k ReactiveSet.t; } (** Per-call metrics scratch state. Allocated once per fixpoint instance, mutable fields are reset and incremented in-place — zero allocation. *) type 'k t = { - current: ('k, unit) ReactiveHash.Map.t; + current: 'k ReactiveSet.t; edge_map: ('k, 'k list) ReactiveHash.Map.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; - roots: ('k, unit) ReactiveHash.Map.t; + roots: 'k ReactiveSet.t; output_wave: ('k, unit ReactiveMaybe.t) ReactiveWave.t; (* Scratch tables — allocated once, cleared per apply_list call *) - deleted_nodes: ('k, unit) ReactiveHash.Map.t; - rederive_pending: ('k, unit) ReactiveHash.Map.t; - expansion_seen: ('k, unit) ReactiveHash.Map.t; + deleted_nodes: 'k ReactiveSet.t; + rederive_pending: 'k ReactiveSet.t; + expansion_seen: 'k ReactiveSet.t; old_successors_for_changed: ('k, 'k list) ReactiveHash.Map.t; new_successors_for_changed: ('k, 'k list) ReactiveHash.Map.t; (* Scratch sets for analyze_edge_change / apply_edge_update *) - scratch_set_a: 'k ReactiveHash.Set.t; - scratch_set_b: 'k ReactiveHash.Set.t; - edge_has_new: 'k ReactiveHash.Set.t; + scratch_set_a: 'k ReactiveSet.t; + scratch_set_b: 'k ReactiveSet.t; + edge_has_new: 'k ReactiveSet.t; (* Scratch queues *) delete_queue: 'k ReactiveQueue.t; rederive_queue: 'k ReactiveQueue.t; @@ -63,25 +61,32 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = List.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; List.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs +let[@inline] off_key k = ReactiveAllocator.unsafe_to_offheap k + (* 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_root visited frontier _t k () = - ReactiveHash.Map.replace visited k (); + ReactiveSet.add visited (off_key k); ReactiveQueue.push frontier k let bfs_visit_succ visited frontier succ = - if not (ReactiveHash.Map.mem visited succ) then ( - ReactiveHash.Map.replace visited succ (); + if not (ReactiveSet.mem visited (off_key succ)) then ( + ReactiveSet.add visited (off_key succ); ReactiveQueue.push frontier succ) let compute_reachable ~visited t = - ReactiveHash.Map.clear visited; + ReactiveSet.clear visited; let frontier = t.delete_queue in ReactiveQueue.clear frontier; let node_work = ref 0 in let edge_work = ref 0 in - ReactiveHash.Map.iter_with (bfs_seed_root visited frontier) t t.roots; + ReactiveSet.iter_with + (fun (visited, frontier) k -> + bfs_seed_root visited frontier t + (ReactiveAllocator.unsafe_from_offheap k) + ()) + (visited, frontier) t.roots; while not (ReactiveQueue.is_empty frontier) do let k = ReactiveQueue.pop frontier in incr node_work; @@ -232,11 +237,14 @@ module Invariants = struct let assert_ condition message = if enabled && not condition then failwith message - (* Debug-only: copies a ReactiveHash.Map set into a Hashtbl for diffing. + (* Debug-only: copies a set into a Hashtbl for diffing. These allocations are acceptable since Invariants is opt-in debug code. *) - let copy_rh_set_to_hashtbl (rh : ('k, unit) ReactiveHash.Map.t) = - let out = Hashtbl.create (ReactiveHash.Map.cardinal rh) in - ReactiveHash.Map.iter (fun k () -> Hashtbl.replace out k ()) rh; + let copy_set_to_hashtbl (s : 'k ReactiveSet.t) = + let out = Hashtbl.create (ReactiveSet.cardinal s) in + ReactiveSet.iter_with + (fun out k -> + Hashtbl.replace out (ReactiveAllocator.unsafe_from_offheap k) ()) + out s; out let set_equal a b = @@ -281,7 +289,7 @@ module Invariants = struct let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs in - let actual_has_new = ReactiveHash.Set.mem edge_has_new src in + let actual_has_new = ReactiveSet.mem edge_has_new (off_key src) in assert_ (expected_has_new = actual_has_new) "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") @@ -289,40 +297,43 @@ module Invariants = struct let assert_deleted_nodes_closed ~current ~deleted_nodes ~old_successors = if enabled then - ReactiveHash.Map.iter - (fun k () -> + ReactiveSet.iter_with + (fun () k -> + let k = ReactiveAllocator.unsafe_from_offheap k in assert_ - (ReactiveHash.Map.mem current k) + (ReactiveSet.mem current (off_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; List.iter (fun succ -> - if ReactiveHash.Map.mem current succ then + if ReactiveSet.mem current (off_key succ) then assert_ - (ReactiveHash.Map.mem deleted_nodes succ) + (ReactiveSet.mem deleted_nodes (off_key succ)) "ReactiveFixpoint.apply invariant failed: deleted closure \ broken") (old_successors k)) - deleted_nodes + () deleted_nodes let assert_no_supported_deleted_left ~deleted_nodes ~current ~supported = if enabled then - ReactiveHash.Map.iter - (fun k () -> - if not (ReactiveHash.Map.mem current k) then + ReactiveSet.iter_with + (fun () k -> + let k = ReactiveAllocator.unsafe_from_offheap k in + if not (ReactiveSet.mem current (off_key k)) then assert_ (not (supported k)) "ReactiveFixpoint.apply invariant failed: supported deleted node \ left behind") - deleted_nodes + () deleted_nodes let assert_current_minus_deleted ~pre_current ~current ~deleted_nodes = if enabled then ( let expected = Hashtbl.copy pre_current in - ReactiveHash.Map.iter - (fun k () -> Hashtbl.remove expected k) - deleted_nodes; - let current_ht = copy_rh_set_to_hashtbl current in + ReactiveSet.iter_with + (fun expected k -> + Hashtbl.remove expected (ReactiveAllocator.unsafe_from_offheap k)) + expected deleted_nodes; + let current_ht = copy_set_to_hashtbl current in assert_ (set_equal expected current_ht) "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ @@ -330,12 +341,13 @@ module Invariants = struct let assert_removal_output_matches ~output_entries ~deleted_nodes ~current = if enabled then ( - let expected = Hashtbl.create (ReactiveHash.Map.cardinal deleted_nodes) in - ReactiveHash.Map.iter - (fun k () -> - if not (ReactiveHash.Map.mem current k) then + let expected = Hashtbl.create (ReactiveSet.cardinal deleted_nodes) in + ReactiveSet.iter_with + (fun expected k -> + let k = ReactiveAllocator.unsafe_from_offheap k in + if not (ReactiveSet.mem current (off_key k)) then Hashtbl.replace expected k ()) - deleted_nodes; + expected deleted_nodes; let actual = Hashtbl.create (List.length output_entries) in List.iter (fun (k, mv) -> @@ -348,25 +360,24 @@ module Invariants = struct let assert_final_fixpoint_and_delta ~visited ~t ~pre_current ~output_entries = if enabled then ( ignore (compute_reachable ~visited t); - let reachable = copy_rh_set_to_hashtbl visited in - let current_ht = copy_rh_set_to_hashtbl t.current in + let reachable = copy_set_to_hashtbl visited in + let current_ht = copy_set_to_hashtbl t.current in assert_ (set_equal reachable current_ht) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; - let expected_adds = - Hashtbl.create (ReactiveHash.Map.cardinal t.current) - in + let expected_adds = Hashtbl.create (ReactiveSet.cardinal t.current) in let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in - ReactiveHash.Map.iter - (fun k () -> + ReactiveSet.iter_with + (fun expected_adds k -> + let k = ReactiveAllocator.unsafe_from_offheap k in if not (Hashtbl.mem pre_current k) then Hashtbl.replace expected_adds k ()) - t.current; + expected_adds t.current; Hashtbl.iter (fun k () -> - if not (ReactiveHash.Map.mem t.current k) then + if not (ReactiveSet.mem t.current (off_key k)) then Hashtbl.replace expected_removes k ()) pre_current; @@ -387,7 +398,7 @@ module Invariants = struct (pre=%d final=%d output=%d expected_adds=%d actual_adds=%d \ expected_removes=%d actual_removes=%d)" (Hashtbl.length pre_current) - (ReactiveHash.Map.cardinal t.current) + (ReactiveSet.cardinal t.current) (List.length output_entries) (Hashtbl.length expected_adds) (Hashtbl.length actual_adds) @@ -401,18 +412,18 @@ let create ~max_nodes ~max_edges = if max_edges <= 0 then invalid_arg "ReactiveFixpoint.create: max_edges must be > 0"; { - current = ReactiveHash.Map.create (); + current = ReactiveSet.create (); edge_map = ReactiveHash.Map.create (); pred_map = ReactivePoolMapSet.create ~capacity:128; - roots = ReactiveHash.Map.create (); + roots = ReactiveSet.create (); output_wave = ReactiveWave.create ~max_entries:max_nodes (); - deleted_nodes = ReactiveHash.Map.create (); - rederive_pending = ReactiveHash.Map.create (); - expansion_seen = ReactiveHash.Map.create (); + deleted_nodes = ReactiveSet.create (); + rederive_pending = ReactiveSet.create (); + expansion_seen = ReactiveSet.create (); old_successors_for_changed = ReactiveHash.Map.create (); - scratch_set_a = ReactiveHash.Set.create (); - scratch_set_b = ReactiveHash.Set.create (); - edge_has_new = ReactiveHash.Set.create (); + scratch_set_a = ReactiveSet.create (); + scratch_set_b = ReactiveSet.create (); + edge_has_new = ReactiveSet.create (); delete_queue = ReactiveQueue.create (); rederive_queue = ReactiveQueue.create (); expansion_queue = ReactiveQueue.create (); @@ -428,11 +439,21 @@ let create ~max_nodes ~max_edges = rederive_edges_scanned = 0; expansion_queue_pops = 0; expansion_edges_scanned = 0; - scratch_reachable = ReactiveHash.Map.create (); + scratch_reachable = ReactiveSet.create (); }; } -let destroy t = ReactiveWave.destroy t.output_wave +let destroy t = + ReactiveSet.destroy t.current; + ReactiveSet.destroy t.roots; + ReactiveSet.destroy t.deleted_nodes; + ReactiveSet.destroy t.rederive_pending; + ReactiveSet.destroy t.expansion_seen; + ReactiveSet.destroy t.scratch_set_a; + ReactiveSet.destroy t.scratch_set_b; + ReactiveSet.destroy t.edge_has_new; + ReactiveSet.destroy t.metrics.scratch_reachable; + ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave type 'k root_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t @@ -441,9 +462,16 @@ type 'k output_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t -let iter_current t f = ReactiveHash.Map.iter f t.current -let get_current t k = ReactiveHash.Map.find_maybe t.current k -let current_length t = ReactiveHash.Map.cardinal t.current +let iter_current t f = + ReactiveSet.iter_with + (fun f k -> f (ReactiveAllocator.unsafe_from_offheap k) ()) + f t.current + +let get_current t k = + if ReactiveSet.mem t.current (off_key k) then ReactiveMaybe.some () + else ReactiveMaybe.none + +let current_length t = ReactiveSet.cardinal t.current let recompute_current t = ignore (compute_reachable ~visited:t.current t) @@ -452,7 +480,7 @@ let add_pred t ~target ~pred = ReactivePoolMapSet.add t.pred_map target pred let remove_pred t ~target ~pred = ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred -let has_live_pred_key t pred = ReactiveHash.Map.mem t.current pred +let has_live_pred_key t pred = ReactiveSet.mem t.current (off_key pred) let has_live_predecessor t k = let r = ReactivePoolMapSet.find_maybe t.pred_map k in @@ -475,33 +503,34 @@ let apply_edge_update t ~src ~new_successors = List.iter (fun target -> remove_pred t ~target ~pred:src) old_successors; ReactiveHash.Map.remove t.edge_map src | _, _ -> - ReactiveHash.Set.clear t.scratch_set_a; - ReactiveHash.Set.clear t.scratch_set_b; - List.iter (fun k -> ReactiveHash.Set.add t.scratch_set_a k) new_successors; - List.iter (fun k -> ReactiveHash.Set.add t.scratch_set_b k) old_successors; + ReactiveSet.clear t.scratch_set_a; + ReactiveSet.clear t.scratch_set_b; + List.iter + (fun k -> ReactiveSet.add t.scratch_set_a (off_key k)) + new_successors; + List.iter + (fun k -> ReactiveSet.add t.scratch_set_b (off_key k)) + old_successors; List.iter (fun target -> - if not (ReactiveHash.Set.mem t.scratch_set_a target) then + if not (ReactiveSet.mem t.scratch_set_a (off_key target)) then remove_pred t ~target ~pred:src) old_successors; List.iter (fun target -> - if not (ReactiveHash.Set.mem t.scratch_set_b target) then + if not (ReactiveSet.mem t.scratch_set_b (off_key target)) then add_pred t ~target ~pred:src) new_successors; ReactiveHash.Map.replace t.edge_map src new_successors let initialize t ~roots ~edges = - ReactiveHash.Map.clear t.roots; + ReactiveSet.clear t.roots; ReactiveHash.Map.clear t.edge_map; ReactivePoolMapSet.clear t.pred_map; - ReactiveWave.iter roots (fun k _ -> - ReactiveHash.Map.replace t.roots - (ReactiveAllocator.unsafe_from_offheap k) - ()); + ReactiveWave.iter roots (fun k _ -> ReactiveSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> apply_edge_update t ~src:(ReactiveAllocator.unsafe_from_offheap k) @@ -509,7 +538,7 @@ let initialize t ~roots ~edges = recompute_current t let is_supported t k = - ReactiveHash.Map.mem t.roots k || has_live_predecessor t k + ReactiveSet.mem t.roots (off_key k) || has_live_predecessor t k let old_successors t k = let r = ReactiveHash.Map.find_maybe t.old_successors_for_changed k in @@ -520,24 +549,24 @@ let old_successors t k = let mark_deleted t k = if - ReactiveHash.Map.mem t.current k - && not (ReactiveHash.Map.mem t.deleted_nodes k) + ReactiveSet.mem t.current (off_key k) + && not (ReactiveSet.mem t.deleted_nodes (off_key k)) then ( - ReactiveHash.Map.replace t.deleted_nodes k (); + ReactiveSet.add t.deleted_nodes (off_key k); ReactiveQueue.push t.delete_queue k) let enqueue_expand t k = if - ReactiveHash.Map.mem t.current k - && not (ReactiveHash.Map.mem t.expansion_seen k) + ReactiveSet.mem t.current (off_key k) + && not (ReactiveSet.mem t.expansion_seen (off_key k)) then ( - ReactiveHash.Map.replace t.expansion_seen k (); + ReactiveSet.add t.expansion_seen (off_key k); ReactiveQueue.push t.expansion_queue k) let add_live t k = - if not (ReactiveHash.Map.mem t.current k) then ( - ReactiveHash.Map.replace t.current k (); - if not (ReactiveHash.Map.mem t.deleted_nodes k) then + if not (ReactiveSet.mem t.current (off_key k)) then ( + ReactiveSet.add t.current (off_key k); + if not (ReactiveSet.mem t.deleted_nodes (off_key k)) then ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k) (ReactiveMaybe.maybe_unit_to_offheap (ReactiveMaybe.some ())); @@ -545,32 +574,32 @@ let add_live t k = let enqueue_rederive_if_needed t k = if - ReactiveHash.Map.mem t.deleted_nodes k - && (not (ReactiveHash.Map.mem t.current k)) - && (not (ReactiveHash.Map.mem t.rederive_pending k)) + ReactiveSet.mem t.deleted_nodes (off_key k) + && (not (ReactiveSet.mem t.current (off_key k))) + && (not (ReactiveSet.mem t.rederive_pending (off_key k))) && is_supported t k then ( - ReactiveHash.Map.replace t.rederive_pending k (); + ReactiveSet.add t.rederive_pending (off_key k); ReactiveQueue.push t.rederive_queue k) let scan_root_entry t k mv = - let had_root = ReactiveHash.Map.mem t.roots k in + let had_root = ReactiveSet.mem t.roots (off_key k) in if ReactiveMaybe.is_some mv then ( if not had_root then ReactiveQueue.push t.added_roots_queue k) else if had_root then mark_deleted t k -let set_add_k set k = ReactiveHash.Set.add set k +let set_add_k set k = ReactiveSet.add set (off_key k) let rec mark_deleted_unless_in_set t set = function | [] -> () | k :: rest -> - if not (ReactiveHash.Set.mem set k) then mark_deleted t k; + if not (ReactiveSet.mem set (off_key k)) then mark_deleted t k; mark_deleted_unless_in_set t set rest let rec list_exists_not_in_set set = function | [] -> false | k :: rest -> - (not (ReactiveHash.Set.mem set k)) || list_exists_not_in_set set rest + (not (ReactiveSet.mem set (off_key k))) || list_exists_not_in_set set rest let scan_edge_entry t src mv = let r = ReactiveHash.Map.find_maybe t.edge_map src in @@ -583,26 +612,26 @@ let scan_edge_entry t src mv = ReactiveHash.Map.replace t.old_successors_for_changed src old_succs; ReactiveHash.Map.replace t.new_successors_for_changed src new_succs; ReactiveQueue.push t.edge_change_queue src; - let src_is_live = ReactiveHash.Map.mem t.current src in + let src_is_live = ReactiveSet.mem t.current (off_key src) in match (old_succs, new_succs) with | [], [] -> () - | [], _ -> ReactiveHash.Set.add t.edge_has_new src + | [], _ -> ReactiveSet.add t.edge_has_new (off_key src) | _, [] -> if src_is_live then list_iter_with mark_deleted t old_succs | _, _ -> - ReactiveHash.Set.clear t.scratch_set_a; - ReactiveHash.Set.clear t.scratch_set_b; + ReactiveSet.clear t.scratch_set_a; + ReactiveSet.clear t.scratch_set_b; list_iter_with set_add_k t.scratch_set_a new_succs; list_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 list_exists_not_in_set t.scratch_set_b new_succs then - ReactiveHash.Set.add t.edge_has_new src + ReactiveSet.add t.edge_has_new (off_key src) let apply_root_mutation t k mv = - if ReactiveMaybe.is_some mv then ReactiveHash.Map.replace t.roots k () - else ReactiveHash.Map.remove t.roots k + if ReactiveMaybe.is_some mv then ReactiveSet.add t.roots (off_key k) + else ReactiveSet.remove t.roots (off_key k) let emit_removal t k () = - if not (ReactiveHash.Map.mem t.current k) then + if not (ReactiveSet.mem t.current (off_key k)) then ReactiveWave.push t.output_wave (ReactiveAllocator.unsafe_to_offheap k) ReactiveMaybe.none_offheap @@ -610,24 +639,23 @@ let emit_removal t k () = let rebuild_edge_change_queue t src _succs = ReactiveQueue.push t.edge_change_queue src -let remove_from_current t k () = ReactiveHash.Map.remove t.current k +let remove_from_current t k = ReactiveSet.remove t.current k -let enqueue_rederive_if_needed_kv t k () = enqueue_rederive_if_needed t k +let enqueue_rederive_if_needed_kv t k = enqueue_rederive_if_needed t k let apply_list t ~roots ~edges = let pre_current = - if Invariants.enabled then - Some (Invariants.copy_rh_set_to_hashtbl t.current) + if Invariants.enabled then Some (Invariants.copy_set_to_hashtbl t.current) else None in (* Clear all scratch state up front *) - ReactiveHash.Map.clear t.deleted_nodes; + ReactiveSet.clear t.deleted_nodes; ReactiveQueue.clear t.delete_queue; ReactiveQueue.clear t.added_roots_queue; ReactiveQueue.clear t.edge_change_queue; ReactiveHash.Map.clear t.old_successors_for_changed; ReactiveHash.Map.clear t.new_successors_for_changed; - ReactiveHash.Set.clear t.edge_has_new; + ReactiveSet.clear t.edge_has_new; let m = t.metrics in Metrics.reset_per_call m; @@ -690,7 +718,7 @@ let apply_list t ~roots ~edges = ReactiveHash.Map.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; - ReactiveHash.Map.iter_with remove_from_current t t.deleted_nodes; + ReactiveSet.iter_with remove_from_current t t.deleted_nodes; (match pre_current with | Some pre -> Invariants.assert_current_minus_deleted ~pre_current:pre ~current:t.current @@ -699,20 +727,23 @@ let apply_list t ~roots ~edges = (* Phase 4: rederive *) ReactiveQueue.clear t.rederive_queue; - ReactiveHash.Map.clear t.rederive_pending; + ReactiveSet.clear t.rederive_pending; - ReactiveHash.Map.iter_with enqueue_rederive_if_needed_kv t t.deleted_nodes; + ReactiveSet.iter_with + (fun t k -> + enqueue_rederive_if_needed_kv t (ReactiveAllocator.unsafe_from_offheap k)) + t t.deleted_nodes; while not (ReactiveQueue.is_empty t.rederive_queue) do let k = ReactiveQueue.pop t.rederive_queue in if Metrics.enabled then m.rederive_queue_pops <- m.rederive_queue_pops + 1; - ReactiveHash.Map.remove t.rederive_pending k; + ReactiveSet.remove t.rederive_pending (off_key k); if - ReactiveHash.Map.mem t.deleted_nodes k - && (not (ReactiveHash.Map.mem t.current k)) + ReactiveSet.mem t.deleted_nodes (off_key k) + && (not (ReactiveSet.mem t.current (off_key k))) && is_supported t k then ( - ReactiveHash.Map.replace t.current k (); + ReactiveSet.add t.current (off_key k); if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; let r = ReactiveHash.Map.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( @@ -728,7 +759,7 @@ let apply_list t ~roots ~edges = (* Phase 5: expansion *) ReactiveQueue.clear t.expansion_queue; - ReactiveHash.Map.clear t.expansion_seen; + ReactiveSet.clear t.expansion_seen; (* Seed expansion from added roots *) while not (ReactiveQueue.is_empty t.added_roots_queue) do @@ -739,8 +770,8 @@ let apply_list t ~roots ~edges = while not (ReactiveQueue.is_empty t.edge_change_queue) do let src = ReactiveQueue.pop t.edge_change_queue in if - ReactiveHash.Map.mem t.current src - && ReactiveHash.Set.mem t.edge_has_new src + ReactiveSet.mem t.current (off_key src) + && ReactiveSet.mem t.edge_has_new (off_key src) then enqueue_expand t src done; @@ -755,7 +786,9 @@ let apply_list t ~roots ~edges = m.expansion_edges_scanned + List.length succs; list_iter_with add_live t succs) done; - ReactiveHash.Map.iter_with emit_removal t t.deleted_nodes; + ReactiveSet.iter_with + (fun t k -> emit_removal t (ReactiveAllocator.unsafe_from_offheap k) ()) + t t.deleted_nodes; let output_entries_list = if Invariants.enabled then ( let entries = ref [] in @@ -792,7 +825,7 @@ let apply_list t ~roots ~edges = in Metrics.update ~init_entries:init_count ~edge_entries:edge_count ~output_entries:(ReactiveWave.count t.output_wave) - ~deleted_nodes:(ReactiveHash.Map.cardinal t.deleted_nodes) + ~deleted_nodes:(ReactiveSet.cardinal t.deleted_nodes) ~rederived_nodes:m.rederived_nodes ~incr_node_work ~incr_edge_work ~full_node_work ~full_edge_work diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/ReactiveMap.ml index 0789af3a958..633892bdd82 100644 --- a/analysis/reactive/src/ReactiveMap.ml +++ b/analysis/reactive/src/ReactiveMap.ml @@ -130,6 +130,23 @@ let remove t k = else j := next t !j done +let mem t k = + let empty : 'k ReactiveAllocator.offheap = empty_slot () in + let tomb : 'k ReactiveAllocator.offheap = 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 = ReactiveAllocator.Block2.get t.keys !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 ReactiveAllocator.offheap = empty_slot () in let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in diff --git a/analysis/reactive/src/ReactiveMap.mli b/analysis/reactive/src/ReactiveMap.mli index 84eb75880b9..a247170c9e1 100644 --- a/analysis/reactive/src/ReactiveMap.mli +++ b/analysis/reactive/src/ReactiveMap.mli @@ -14,6 +14,8 @@ val replace : val remove : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> unit +val mem : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> bool + val find_maybe : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> diff --git a/analysis/reactive/src/ReactiveSet.ml b/analysis/reactive/src/ReactiveSet.ml index f85d4e19478..2183e047dbd 100644 --- a/analysis/reactive/src/ReactiveSet.ml +++ b/analysis/reactive/src/ReactiveSet.ml @@ -8,8 +8,10 @@ The backing block lives off-heap. Elements are ordinary OCaml values whose storage invariant has already been established before insertion. - Empty data slots contain a distinguished sentinel value. All other data - slots contain real set elements. *) + 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) ReactiveAllocator.Block2.t @@ -17,8 +19,11 @@ 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 ReactiveAllocator.offheap) +let[@inline] tomb_sentinel = + fun () -> (Obj.magic tomb : 'a ReactiveAllocator.offheap) let slot_capacity = ReactiveAllocator.Block2.capacity let population = ReactiveAllocator.Block2.get0 @@ -53,7 +58,10 @@ let clear t = let add_absent_key (type a) (t : a t) (x : a ReactiveAllocator.offheap) = let j = ref (start t x) in - while ReactiveAllocator.Block2.get t !j != empty_sentinel () do + while + let current = ReactiveAllocator.Block2.get t !j in + current != empty_sentinel () && current != tomb_sentinel () + do j := next t !j done; ReactiveAllocator.Block2.set t !j x @@ -70,7 +78,7 @@ let resize (type a) (t : a t) new_cap = set_mask t (new_cap - 1); for i = 0 to old_cap - 1 do let x = ReactiveAllocator.Block2.get old_keys i in - if x != empty_sentinel () then add_absent_key t x + if x != empty_sentinel () && x != tomb_sentinel () then add_absent_key t x done; ReactiveAllocator.Block2.destroy old_keys @@ -82,23 +90,57 @@ let maybe_grow_before_add (type a) (t : a t) = let add (type a) (t : a t) (x : a ReactiveAllocator.offheap) = 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 = ReactiveAllocator.Block2.get t !j in if current == empty_sentinel () then ( - ReactiveAllocator.Block2.set t !j x; + let dst = if !first_tomb >= 0 then !first_tomb else !j in + ReactiveAllocator.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 ReactiveAllocator.offheap) = + let j = ref (start t x) in + let done_ = ref false in + while not !done_ do + let current = ReactiveAllocator.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 ( + ReactiveAllocator.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 ReactiveAllocator.offheap) = + let j = ref (start t x) in + let found = ref false in + let done_ = ref false in + while not !done_ do + let current = ReactiveAllocator.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 ReactiveAllocator.offheap -> unit) (arg : a) (t : k t) = if population t > 0 then for i = 0 to slot_capacity t - 1 do let x = ReactiveAllocator.Block2.get t i in - if x != empty_sentinel () then f arg x + if x != empty_sentinel () && x != tomb_sentinel () then f arg x done let cardinal = population diff --git a/analysis/reactive/src/ReactiveSet.mli b/analysis/reactive/src/ReactiveSet.mli index c912db880cd..ed5b995ff57 100644 --- a/analysis/reactive/src/ReactiveSet.mli +++ b/analysis/reactive/src/ReactiveSet.mli @@ -18,6 +18,12 @@ val clear : 'a t -> unit val add : 'a t -> 'a ReactiveAllocator.offheap -> unit (** Add an element to the set. Re-adding an existing element is a no-op. *) +val remove : 'a t -> 'a ReactiveAllocator.offheap -> unit +(** Remove an element from the set. Removing a missing element is a no-op. *) + +val mem : 'a t -> 'a ReactiveAllocator.offheap -> bool +(** Test whether the set contains an element. *) + val iter_with : ('b -> 'a ReactiveAllocator.offheap -> unit) -> 'b -> 'a t -> unit (** [iter_with f arg t] calls [f arg x] for each element. *) From 67f74675956a2b7562c9888f28211651d3fd88d9 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 7 Mar 2026 08:46:12 +0100 Subject: [PATCH 19/54] analysis/reactive: replace queue with off-heap fifo --- .../reactive/src/CONVERTING_COMBINATORS.md | 6 +- analysis/reactive/src/ReactiveFifo.ml | 63 +++++++++++++ analysis/reactive/src/ReactiveFifo.mli | 24 +++++ analysis/reactive/src/ReactiveFixpoint.ml | 94 ++++++++++--------- analysis/reactive/src/ReactiveQueue.ml | 36 ------- analysis/reactive/src/ReactiveQueue.mli | 13 --- analysis/reactive/src/dune | 2 +- 7 files changed, 142 insertions(+), 96 deletions(-) create mode 100644 analysis/reactive/src/ReactiveFifo.ml create mode 100644 analysis/reactive/src/ReactiveFifo.mli delete mode 100644 analysis/reactive/src/ReactiveQueue.ml delete mode 100644 analysis/reactive/src/ReactiveQueue.mli diff --git a/analysis/reactive/src/CONVERTING_COMBINATORS.md b/analysis/reactive/src/CONVERTING_COMBINATORS.md index 3bb65f6c769..b289ef5757c 100644 --- a/analysis/reactive/src/CONVERTING_COMBINATORS.md +++ b/analysis/reactive/src/CONVERTING_COMBINATORS.md @@ -156,9 +156,9 @@ allocation. Switching `unit option` to `ReactiveMaybe.t` does not save allocations (confirmed by measurement). Focus optimization effort on closures and non-unit option types instead. -### Use `ReactiveQueue` for BFS/worklist patterns +### Use `ReactiveFifo` for BFS/worklist patterns -Pre-allocated array-based FIFOs (`ReactiveQueue`) eliminate cons-cell +Off-heap FIFOs (`ReactiveFifo`) eliminate cons-cell allocation from worklist patterns. Clear + push cycles reuse the backing array at steady state. @@ -337,7 +337,7 @@ Converted to `ReactiveHash`: - 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 `ReactiveQueue` (pre-allocated array-based FIFO): +Converted to `ReactiveFifo` (off-heap 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 diff --git a/analysis/reactive/src/ReactiveFifo.ml b/analysis/reactive/src/ReactiveFifo.ml new file mode 100644 index 00000000000..627cc7cec42 --- /dev/null +++ b/analysis/reactive/src/ReactiveFifo.ml @@ -0,0 +1,63 @@ +(* Representation of ['a t]: + + - ['a t] is [('a, int, int) ReactiveAllocator.Block2.t]. + - Header slot [0]: head index. + - Header slot [1]: tail index. + - Data slots: queue elements, stored as ['a ReactiveAllocator.offheap]. + + 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) ReactiveAllocator.Block2.t + +let initial_capacity = 16 + +let head = ReactiveAllocator.Block2.get0 +let set_head = ReactiveAllocator.Block2.set0 +let tail = ReactiveAllocator.Block2.get1 +let set_tail = ReactiveAllocator.Block2.set1 +let slot_capacity = ReactiveAllocator.Block2.capacity + +let create () = + ReactiveAllocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 + +let destroy = ReactiveAllocator.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 = + ReactiveAllocator.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 + ReactiveAllocator.Block2.set fresh i (ReactiveAllocator.Block2.get t src) + done; + ReactiveAllocator.Block2.blit ~src:fresh ~src_pos:0 ~dst:t ~dst_pos:0 + ~len:new_cap; + ReactiveAllocator.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 + ReactiveAllocator.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 "ReactiveFifo.pop: empty"; + let head_i = head t in + let x = ReactiveAllocator.Block2.get t (slot_index t head_i) in + set_head t (head_i + 1); + x diff --git a/analysis/reactive/src/ReactiveFifo.mli b/analysis/reactive/src/ReactiveFifo.mli new file mode 100644 index 00000000000..06eb2c78549 --- /dev/null +++ b/analysis/reactive/src/ReactiveFifo.mli @@ -0,0 +1,24 @@ +(** Off-heap 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 off-heap 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 ReactiveAllocator.offheap -> 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 ReactiveAllocator.offheap +(** Remove and return the next element. + + @raise Invalid_argument if the queue is empty. *) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index d205eb6e0e5..b338b611e8f 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -41,11 +41,11 @@ type 'k t = { scratch_set_b: 'k ReactiveSet.t; edge_has_new: 'k ReactiveSet.t; (* Scratch queues *) - delete_queue: 'k ReactiveQueue.t; - rederive_queue: 'k ReactiveQueue.t; - expansion_queue: 'k ReactiveQueue.t; - added_roots_queue: 'k ReactiveQueue.t; - edge_change_queue: 'k ReactiveQueue.t; + delete_queue: 'k ReactiveFifo.t; + rederive_queue: 'k ReactiveFifo.t; + expansion_queue: 'k ReactiveFifo.t; + added_roots_queue: 'k ReactiveFifo.t; + edge_change_queue: 'k ReactiveFifo.t; metrics: 'k metrics_state; } @@ -62,23 +62,25 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = List.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs let[@inline] off_key k = ReactiveAllocator.unsafe_to_offheap k +let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) +let[@inline] pop_key q = ReactiveAllocator.unsafe_from_offheap (ReactiveFifo.pop q) (* 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_root visited frontier _t k () = ReactiveSet.add visited (off_key k); - ReactiveQueue.push frontier k + enqueue frontier k let bfs_visit_succ visited frontier succ = if not (ReactiveSet.mem visited (off_key succ)) then ( ReactiveSet.add visited (off_key succ); - ReactiveQueue.push frontier succ) + enqueue frontier succ) let compute_reachable ~visited t = ReactiveSet.clear visited; let frontier = t.delete_queue in - ReactiveQueue.clear frontier; + ReactiveFifo.clear frontier; let node_work = ref 0 in let edge_work = ref 0 in ReactiveSet.iter_with @@ -87,8 +89,8 @@ let compute_reachable ~visited t = (ReactiveAllocator.unsafe_from_offheap k) ()) (visited, frontier) t.roots; - while not (ReactiveQueue.is_empty frontier) do - let k = ReactiveQueue.pop frontier in + while not (ReactiveFifo.is_empty frontier) do + let k = pop_key frontier in incr node_work; let r = ReactiveHash.Map.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( @@ -257,18 +259,19 @@ module Invariants = struct let assert_edge_has_new_consistent ~edge_change_queue ~old_successors_for_changed ~new_successors_for_changed ~edge_has_new = if enabled then ( - let q_copy = ReactiveQueue.create () in + let q_copy = ReactiveFifo.create () in (* Drain and re-push to iterate without consuming *) let items = ref [] in - while not (ReactiveQueue.is_empty edge_change_queue) do - let src = ReactiveQueue.pop edge_change_queue in + while not (ReactiveFifo.is_empty edge_change_queue) do + let src = pop_key edge_change_queue in items := src :: !items; - ReactiveQueue.push q_copy src + enqueue q_copy src done; (* Restore queue *) List.iter - (fun src -> ReactiveQueue.push edge_change_queue src) + (fun src -> enqueue edge_change_queue src) (List.rev !items); + ReactiveFifo.destroy q_copy; (* Check each *) List.iter (fun src -> @@ -424,11 +427,11 @@ let create ~max_nodes ~max_edges = scratch_set_a = ReactiveSet.create (); scratch_set_b = ReactiveSet.create (); edge_has_new = ReactiveSet.create (); - delete_queue = ReactiveQueue.create (); - rederive_queue = ReactiveQueue.create (); - expansion_queue = ReactiveQueue.create (); - added_roots_queue = ReactiveQueue.create (); - edge_change_queue = ReactiveQueue.create (); + delete_queue = ReactiveFifo.create (); + rederive_queue = ReactiveFifo.create (); + expansion_queue = ReactiveFifo.create (); + added_roots_queue = ReactiveFifo.create (); + edge_change_queue = ReactiveFifo.create (); new_successors_for_changed = ReactiveHash.Map.create (); metrics = { @@ -452,6 +455,11 @@ let destroy t = ReactiveSet.destroy t.scratch_set_a; ReactiveSet.destroy t.scratch_set_b; ReactiveSet.destroy t.edge_has_new; + ReactiveFifo.destroy t.delete_queue; + ReactiveFifo.destroy t.rederive_queue; + ReactiveFifo.destroy t.expansion_queue; + ReactiveFifo.destroy t.added_roots_queue; + ReactiveFifo.destroy t.edge_change_queue; ReactiveSet.destroy t.metrics.scratch_reachable; ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave @@ -553,7 +561,7 @@ let mark_deleted t k = && not (ReactiveSet.mem t.deleted_nodes (off_key k)) then ( ReactiveSet.add t.deleted_nodes (off_key k); - ReactiveQueue.push t.delete_queue k) + enqueue t.delete_queue k) let enqueue_expand t k = if @@ -561,7 +569,7 @@ let enqueue_expand t k = && not (ReactiveSet.mem t.expansion_seen (off_key k)) then ( ReactiveSet.add t.expansion_seen (off_key k); - ReactiveQueue.push t.expansion_queue k) + enqueue t.expansion_queue k) let add_live t k = if not (ReactiveSet.mem t.current (off_key k)) then ( @@ -580,12 +588,12 @@ let enqueue_rederive_if_needed t k = && is_supported t k then ( ReactiveSet.add t.rederive_pending (off_key k); - ReactiveQueue.push t.rederive_queue k) + enqueue t.rederive_queue k) let scan_root_entry t k mv = let had_root = ReactiveSet.mem t.roots (off_key k) in if ReactiveMaybe.is_some mv then ( - if not had_root then ReactiveQueue.push t.added_roots_queue k) + if not had_root then enqueue t.added_roots_queue k) else if had_root then mark_deleted t k let set_add_k set k = ReactiveSet.add set (off_key k) @@ -611,7 +619,7 @@ let scan_edge_entry t src mv = in ReactiveHash.Map.replace t.old_successors_for_changed src old_succs; ReactiveHash.Map.replace t.new_successors_for_changed src new_succs; - ReactiveQueue.push t.edge_change_queue src; + enqueue t.edge_change_queue src; let src_is_live = ReactiveSet.mem t.current (off_key src) in match (old_succs, new_succs) with | [], [] -> () @@ -637,7 +645,7 @@ let emit_removal t k () = ReactiveMaybe.none_offheap let rebuild_edge_change_queue t src _succs = - ReactiveQueue.push t.edge_change_queue src + enqueue t.edge_change_queue src let remove_from_current t k = ReactiveSet.remove t.current k @@ -650,9 +658,9 @@ let apply_list t ~roots ~edges = in (* Clear all scratch state up front *) ReactiveSet.clear t.deleted_nodes; - ReactiveQueue.clear t.delete_queue; - ReactiveQueue.clear t.added_roots_queue; - ReactiveQueue.clear t.edge_change_queue; + ReactiveFifo.clear t.delete_queue; + ReactiveFifo.clear t.added_roots_queue; + ReactiveFifo.clear t.edge_change_queue; ReactiveHash.Map.clear t.old_successors_for_changed; ReactiveHash.Map.clear t.new_successors_for_changed; ReactiveSet.clear t.edge_has_new; @@ -684,8 +692,8 @@ let apply_list t ~roots ~edges = ~edge_has_new:t.edge_has_new; (* Phase 2: delete BFS *) - while not (ReactiveQueue.is_empty t.delete_queue) do - let k = ReactiveQueue.pop t.delete_queue in + while not (ReactiveFifo.is_empty t.delete_queue) do + let k = pop_key t.delete_queue in let succs = old_successors t k in if Metrics.enabled then ( m.delete_queue_pops <- m.delete_queue_pops + 1; @@ -705,8 +713,8 @@ let apply_list t ~roots ~edges = t; (* Apply edge updates by draining edge_change_queue. *) - while not (ReactiveQueue.is_empty t.edge_change_queue) do - let src = ReactiveQueue.pop t.edge_change_queue in + while not (ReactiveFifo.is_empty t.edge_change_queue) do + let src = pop_key t.edge_change_queue in let r = ReactiveHash.Map.find_maybe t.new_successors_for_changed src in let new_succs = if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] @@ -726,7 +734,7 @@ let apply_list t ~roots ~edges = | None -> ()); (* Phase 4: rederive *) - ReactiveQueue.clear t.rederive_queue; + ReactiveFifo.clear t.rederive_queue; ReactiveSet.clear t.rederive_pending; ReactiveSet.iter_with @@ -734,8 +742,8 @@ let apply_list t ~roots ~edges = enqueue_rederive_if_needed_kv t (ReactiveAllocator.unsafe_from_offheap k)) t t.deleted_nodes; - while not (ReactiveQueue.is_empty t.rederive_queue) do - let k = ReactiveQueue.pop t.rederive_queue in + while not (ReactiveFifo.is_empty t.rederive_queue) do + let k = pop_key t.rederive_queue in if Metrics.enabled then m.rederive_queue_pops <- m.rederive_queue_pops + 1; ReactiveSet.remove t.rederive_pending (off_key k); if @@ -758,25 +766,25 @@ let apply_list t ~roots ~edges = ~current:t.current ~supported:(is_supported t); (* Phase 5: expansion *) - ReactiveQueue.clear t.expansion_queue; + ReactiveFifo.clear t.expansion_queue; ReactiveSet.clear t.expansion_seen; (* Seed expansion from added roots *) - while not (ReactiveQueue.is_empty t.added_roots_queue) do - add_live t (ReactiveQueue.pop t.added_roots_queue) + while not (ReactiveFifo.is_empty t.added_roots_queue) do + add_live t (pop_key t.added_roots_queue) done; (* Seed expansion from edge changes with new edges *) - while not (ReactiveQueue.is_empty t.edge_change_queue) do - let src = ReactiveQueue.pop t.edge_change_queue in + while not (ReactiveFifo.is_empty t.edge_change_queue) do + let src = pop_key t.edge_change_queue in if ReactiveSet.mem t.current (off_key src) && ReactiveSet.mem t.edge_has_new (off_key src) then enqueue_expand t src done; - while not (ReactiveQueue.is_empty t.expansion_queue) do - let k = ReactiveQueue.pop t.expansion_queue in + while not (ReactiveFifo.is_empty t.expansion_queue) do + let k = pop_key t.expansion_queue in if Metrics.enabled then m.expansion_queue_pops <- m.expansion_queue_pops + 1; let r = ReactiveHash.Map.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( diff --git a/analysis/reactive/src/ReactiveQueue.ml b/analysis/reactive/src/ReactiveQueue.ml deleted file mode 100644 index e13f5f84fba..00000000000 --- a/analysis/reactive/src/ReactiveQueue.ml +++ /dev/null @@ -1,36 +0,0 @@ -(** Array-based FIFO queue. After [clear], subsequent [push] calls - reuse existing array slots — zero allocation until the array - needs to grow beyond its high-water mark. *) - -type 'a t = { - mutable data: Obj.t array; - mutable head: int; - mutable tail: int; (* next write position *) -} - -let create () = {data = [||]; head = 0; tail = 0} -let clear t = - t.head <- 0; - t.tail <- 0 -let is_empty t = t.head = t.tail - -let grow t = - let old_len = Array.length t.data in - let used = t.tail - t.head in - let new_len = max 16 (old_len * 2) in - let new_data = Array.make new_len (Obj.repr ()) in - Array.blit t.data t.head new_data 0 used; - t.data <- new_data; - t.head <- 0; - t.tail <- used - -let push t (x : 'a) = - if t.tail >= Array.length t.data then grow t; - Array.unsafe_set t.data t.tail (Obj.repr x); - t.tail <- t.tail + 1 - -let pop t = - if t.head = t.tail then invalid_arg "ReactiveQueue.pop: empty"; - let v = Array.unsafe_get t.data t.head in - t.head <- t.head + 1; - (Obj.obj v : 'a) diff --git a/analysis/reactive/src/ReactiveQueue.mli b/analysis/reactive/src/ReactiveQueue.mli deleted file mode 100644 index e54d325fe77..00000000000 --- a/analysis/reactive/src/ReactiveQueue.mli +++ /dev/null @@ -1,13 +0,0 @@ -(** Array-based FIFO queue. After [clear], subsequent [push] calls - reuse existing array slots — zero allocation until the array - needs to grow beyond its high-water mark. *) - -type 'a t - -val create : unit -> 'a t -val clear : 'a t -> unit -val push : 'a t -> 'a -> unit -val is_empty : 'a t -> bool - -val pop : 'a t -> 'a -(** @raise Invalid_argument if the queue is empty. *) diff --git a/analysis/reactive/src/dune b/analysis/reactive/src/dune index f8da2881ed7..49ee4fb33cd 100644 --- a/analysis/reactive/src/dune +++ b/analysis/reactive/src/dune @@ -1,7 +1,7 @@ (library (name reactive) (wrapped false) - (private_modules ReactiveQueue) + (private_modules ReactiveFifo) (foreign_stubs (language c) (names reactive_allocator_stubs)) From ba50091aa7f5e1cd1663de6acb07017918a287c4 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 7 Mar 2026 11:57:39 +0100 Subject: [PATCH 20/54] analysis/reactive: add explicit offheap list boundary --- analysis/reactive/src/Reactive.ml | 17 +- analysis/reactive/src/ReactiveFixpoint.ml | 163 +++++++++--------- analysis/reactive/src/ReactiveMaybe.ml | 4 + analysis/reactive/src/ReactiveMaybe.mli | 5 + analysis/reactive/src/ReactiveOffheapList.ml | 49 ++++++ analysis/reactive/src/ReactiveOffheapList.mli | 25 +++ analysis/reactive/test/AllocTest.ml | 4 +- analysis/reactive/test/BatchTest.ml | 4 +- analysis/reactive/test/FixpointBasicTest.ml | 36 ++-- .../reactive/test/FixpointIncrementalTest.ml | 134 +++++++------- analysis/reactive/test/TestHelpers.ml | 30 ++++ analysis/reanalyze/src/ReactiveLiveness.ml | 3 +- 12 files changed, 303 insertions(+), 171 deletions(-) create mode 100644 analysis/reactive/src/ReactiveOffheapList.ml create mode 100644 analysis/reactive/src/ReactiveOffheapList.mli diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 790764deacb..d293c9264bf 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -835,7 +835,8 @@ module Fixpoint = struct let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in - let edge_pending : ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = + let edge_pending : + ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in let init_pending_count = ref 0 in @@ -858,7 +859,12 @@ module Fixpoint = struct let root_entries = ReactiveHash.Map.cardinal root_pending in let edge_entries = ReactiveHash.Map.cardinal edge_pending in ReactiveHash.Map.iter_with unsafe_wave_push root_wave root_pending; - ReactiveHash.Map.iter_with unsafe_wave_push edge_wave edge_pending; + ReactiveHash.Map.iter_with + (fun wave k mv -> + ReactiveWave.push wave + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap mv)) + edge_wave edge_pending; ReactiveHash.Map.clear root_pending; ReactiveHash.Map.clear edge_pending; @@ -907,13 +913,16 @@ module Fixpoint = struct let init_roots_wave = ReactiveWave.create ~max_entries:(max 1 (init.length ())) () in - let init_edges_wave = + let init_edges_wave : ('k, 'k list) ReactiveWave.t = ReactiveWave.create ~max_entries:(max 1 (edges.length ())) () in ReactiveWave.clear init_roots_wave; ReactiveWave.clear init_edges_wave; init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); - edges.iter (fun k succs -> unsafe_wave_push init_edges_wave k succs); + edges.iter (fun k succs -> + ReactiveWave.push init_edges_wave + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveAllocator.unsafe_to_offheap succs)); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; ReactiveWave.destroy init_roots_wave; diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index b338b611e8f..5b941e7f21a 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -1,12 +1,3 @@ -(** [list_iter_with f arg xs] calls [f arg x] for each [x] in [xs]. - Unlike [List.iter (f arg) xs], this avoids allocating a closure - when [f] is a top-level function. *) -let rec list_iter_with f arg = function - | [] -> () - | x :: rest -> - f arg x; - list_iter_with f arg rest - (* Note on set representations: [pred_map] is represented by [ReactivePoolMapSet] because its semantics are exactly map-of-set with churn-safe remove+recycle behavior. *) @@ -26,7 +17,7 @@ type 'k metrics_state = { type 'k t = { current: 'k ReactiveSet.t; - edge_map: ('k, 'k list) ReactiveHash.Map.t; + edge_map: ('k, 'k ReactiveOffheapList.t) ReactiveHash.Map.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; roots: 'k ReactiveSet.t; output_wave: ('k, unit ReactiveMaybe.t) ReactiveWave.t; @@ -34,8 +25,8 @@ type 'k t = { deleted_nodes: 'k ReactiveSet.t; rederive_pending: 'k ReactiveSet.t; expansion_seen: 'k ReactiveSet.t; - old_successors_for_changed: ('k, 'k list) ReactiveHash.Map.t; - new_successors_for_changed: ('k, 'k list) ReactiveHash.Map.t; + old_successors_for_changed: ('k, 'k ReactiveOffheapList.t) ReactiveHash.Map.t; + new_successors_for_changed: ('k, 'k ReactiveOffheapList.t) ReactiveHash.Map.t; (* Scratch sets for analyze_edge_change / apply_edge_update *) scratch_set_a: 'k ReactiveSet.t; scratch_set_b: 'k ReactiveSet.t; @@ -52,18 +43,20 @@ type 'k t = { (* Standalone version for Invariants (no scratch sets available). Debug-only — allocates temporary Hashtbl. *) let analyze_edge_change_has_new ~old_succs ~new_succs = - match (old_succs, new_succs) with - | [], [] -> false - | [], _ -> true - | _, [] -> false - | _, _ -> - let old_set = Hashtbl.create (List.length old_succs) in - List.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; - List.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs + if ReactiveOffheapList.is_empty old_succs then + not (ReactiveOffheapList.is_empty new_succs) + else if ReactiveOffheapList.is_empty new_succs then false + else + let old_set = Hashtbl.create (ReactiveOffheapList.length old_succs) in + ReactiveOffheapList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; + ReactiveOffheapList.exists + (fun tgt -> not (Hashtbl.mem old_set tgt)) + new_succs let[@inline] off_key k = ReactiveAllocator.unsafe_to_offheap k let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) -let[@inline] pop_key q = ReactiveAllocator.unsafe_from_offheap (ReactiveFifo.pop q) +let[@inline] pop_key q = + ReactiveAllocator.unsafe_from_offheap (ReactiveFifo.pop q) (* Full-reachability BFS into [visited]. Returns (node_work, edge_work). [visited] is cleared before use; zero allocation when [visited] is @@ -95,8 +88,8 @@ let compute_reachable ~visited t = let r = ReactiveHash.Map.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( let succs = ReactiveMaybe.unsafe_get r in - edge_work := !edge_work + List.length succs; - list_iter_with (bfs_visit_succ visited) frontier succs) + edge_work := !edge_work + ReactiveOffheapList.length succs; + ReactiveOffheapList.iter_with (bfs_visit_succ visited) frontier succs) done; (!node_work, !edge_work) @@ -268,9 +261,7 @@ module Invariants = struct enqueue q_copy src done; (* Restore queue *) - List.iter - (fun src -> enqueue edge_change_queue src) - (List.rev !items); + List.iter (fun src -> enqueue edge_change_queue src) (List.rev !items); ReactiveFifo.destroy q_copy; (* Check each *) List.iter @@ -280,14 +271,14 @@ module Invariants = struct in let old_succs = if ReactiveMaybe.is_some r_old then ReactiveMaybe.unsafe_get r_old - else [] + else ReactiveOffheapList.empty () in let r_new = ReactiveHash.Map.find_maybe new_successors_for_changed src in let new_succs = if ReactiveMaybe.is_some r_new then ReactiveMaybe.unsafe_get r_new - else [] + else ReactiveOffheapList.empty () in let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs @@ -298,7 +289,8 @@ module Invariants = struct "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") !items) - let assert_deleted_nodes_closed ~current ~deleted_nodes ~old_successors = + let assert_deleted_nodes_closed ~current ~deleted_nodes + ~(old_successors : 'k -> 'k ReactiveOffheapList.t) = if enabled then ReactiveSet.iter_with (fun () k -> @@ -307,7 +299,7 @@ module Invariants = struct (ReactiveSet.mem current (off_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; - List.iter + ReactiveOffheapList.iter (fun succ -> if ReactiveSet.mem current (off_key succ) then assert_ @@ -497,42 +489,48 @@ let has_live_predecessor t k = (ReactiveMaybe.unsafe_get r) else false +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 r = ReactiveHash.Map.find_maybe t.edge_map src in let old_successors = - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r + else ReactiveOffheapList.empty () in - match (old_successors, new_successors) with - | [], [] -> ReactiveHash.Map.remove t.edge_map src - | [], _ -> - List.iter (fun target -> add_pred t ~target ~pred:src) new_successors; - ReactiveHash.Map.replace t.edge_map src new_successors - | _, [] -> - List.iter (fun target -> remove_pred t ~target ~pred:src) old_successors; - ReactiveHash.Map.remove t.edge_map src - | _, _ -> + if + ReactiveOffheapList.is_empty old_successors + && ReactiveOffheapList.is_empty new_successors + then ReactiveHash.Map.remove t.edge_map src + else if ReactiveOffheapList.is_empty old_successors then ( + ReactiveOffheapList.iter_with add_pred_for_src (t, src) new_successors; + ReactiveHash.Map.replace t.edge_map src new_successors) + else if ReactiveOffheapList.is_empty new_successors then ( + ReactiveOffheapList.iter_with remove_pred_for_src (t, src) old_successors; + ReactiveHash.Map.remove t.edge_map src) + else ( ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; - List.iter + ReactiveOffheapList.iter (fun k -> ReactiveSet.add t.scratch_set_a (off_key k)) new_successors; - List.iter + ReactiveOffheapList.iter (fun k -> ReactiveSet.add t.scratch_set_b (off_key k)) old_successors; - List.iter - (fun target -> + ReactiveOffheapList.iter_with + (fun () target -> if not (ReactiveSet.mem t.scratch_set_a (off_key target)) then remove_pred t ~target ~pred:src) - old_successors; + () old_successors; - List.iter - (fun target -> + ReactiveOffheapList.iter_with + (fun () target -> if not (ReactiveSet.mem t.scratch_set_b (off_key target)) then add_pred t ~target ~pred:src) - new_successors; + () new_successors; - ReactiveHash.Map.replace t.edge_map src new_successors + ReactiveHash.Map.replace t.edge_map src new_successors) let initialize t ~roots ~edges = ReactiveSet.clear t.roots; @@ -542,7 +540,7 @@ let initialize t ~roots ~edges = ReactiveWave.iter edges (fun k successors -> apply_edge_update t ~src:(ReactiveAllocator.unsafe_from_offheap k) - ~new_successors:(ReactiveAllocator.unsafe_from_offheap successors)); + ~new_successors:(ReactiveOffheapList.unsafe_of_offheap_list successors)); recompute_current t let is_supported t k = @@ -553,7 +551,8 @@ let old_successors t k = if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else let r2 = ReactiveHash.Map.find_maybe t.edge_map k in - if ReactiveMaybe.is_some r2 then ReactiveMaybe.unsafe_get r2 else [] + if ReactiveMaybe.is_some r2 then ReactiveMaybe.unsafe_get r2 + else ReactiveOffheapList.empty () let mark_deleted t k = if @@ -598,40 +597,47 @@ let scan_root_entry t k mv = let set_add_k set k = ReactiveSet.add set (off_key k) -let rec mark_deleted_unless_in_set t set = function - | [] -> () - | k :: rest -> - if not (ReactiveSet.mem set (off_key k)) then mark_deleted t k; - mark_deleted_unless_in_set t set rest +let mark_deleted_if_absent (t, set) k = + if not (ReactiveSet.mem set (off_key k)) then mark_deleted t k + +let not_in_set set k = not (ReactiveSet.mem set (off_key k)) + +let mark_deleted_unless_in_set t set xs = + ReactiveOffheapList.iter_with mark_deleted_if_absent (t, set) xs -let rec list_exists_not_in_set set = function - | [] -> false - | k :: rest -> - (not (ReactiveSet.mem set (off_key k))) || list_exists_not_in_set set rest +let exists_not_in_set set xs = ReactiveOffheapList.exists_with not_in_set set xs let scan_edge_entry t src mv = let r = ReactiveHash.Map.find_maybe t.edge_map src in let old_succs = - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r + else ReactiveOffheapList.empty () in let new_succs = - if ReactiveMaybe.is_some mv then ReactiveMaybe.unsafe_get mv else [] + if ReactiveMaybe.is_some mv then + ReactiveOffheapList.unsafe_of_list (ReactiveMaybe.unsafe_get mv) + else ReactiveOffheapList.empty () in ReactiveHash.Map.replace t.old_successors_for_changed src old_succs; ReactiveHash.Map.replace t.new_successors_for_changed src new_succs; enqueue t.edge_change_queue src; let src_is_live = ReactiveSet.mem t.current (off_key src) in match (old_succs, new_succs) with - | [], [] -> () - | [], _ -> ReactiveSet.add t.edge_has_new (off_key src) - | _, [] -> if src_is_live then list_iter_with mark_deleted t old_succs - | _, _ -> + | _ + when ReactiveOffheapList.is_empty old_succs + && ReactiveOffheapList.is_empty new_succs -> + () + | _ when ReactiveOffheapList.is_empty old_succs -> + ReactiveSet.add t.edge_has_new (off_key src) + | _ when ReactiveOffheapList.is_empty new_succs -> + if src_is_live then ReactiveOffheapList.iter_with mark_deleted t old_succs + | _ -> ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; - list_iter_with set_add_k t.scratch_set_a new_succs; - list_iter_with set_add_k t.scratch_set_b old_succs; + ReactiveOffheapList.iter_with set_add_k t.scratch_set_a new_succs; + ReactiveOffheapList.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 list_exists_not_in_set t.scratch_set_b new_succs then + if exists_not_in_set t.scratch_set_b new_succs then ReactiveSet.add t.edge_has_new (off_key src) let apply_root_mutation t k mv = @@ -644,8 +650,7 @@ let emit_removal t k () = (ReactiveAllocator.unsafe_to_offheap k) ReactiveMaybe.none_offheap -let rebuild_edge_change_queue t src _succs = - enqueue t.edge_change_queue src +let rebuild_edge_change_queue t src _succs = enqueue t.edge_change_queue src let remove_from_current t k = ReactiveSet.remove t.current k @@ -697,8 +702,9 @@ let apply_list t ~roots ~edges = 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 + List.length succs); - list_iter_with mark_deleted t succs + m.delete_edges_scanned <- + m.delete_edges_scanned + ReactiveOffheapList.length succs); + ReactiveOffheapList.iter_with mark_deleted t succs done; if Invariants.enabled then Invariants.assert_deleted_nodes_closed ~current:t.current @@ -717,7 +723,8 @@ let apply_list t ~roots ~edges = let src = pop_key t.edge_change_queue in let r = ReactiveHash.Map.find_maybe t.new_successors_for_changed src in let new_succs = - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else [] + if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r + else ReactiveOffheapList.empty () in apply_edge_update t ~src ~new_successors:new_succs done; @@ -758,8 +765,8 @@ let apply_list t ~roots ~edges = let succs = ReactiveMaybe.unsafe_get r in if Metrics.enabled then m.rederive_edges_scanned <- - m.rederive_edges_scanned + List.length succs; - list_iter_with enqueue_rederive_if_needed t succs)) + m.rederive_edges_scanned + ReactiveOffheapList.length succs; + ReactiveOffheapList.iter_with enqueue_rederive_if_needed t succs)) done; if Invariants.enabled then Invariants.assert_no_supported_deleted_left ~deleted_nodes:t.deleted_nodes @@ -791,8 +798,8 @@ let apply_list t ~roots ~edges = let succs = ReactiveMaybe.unsafe_get r in if Metrics.enabled then m.expansion_edges_scanned <- - m.expansion_edges_scanned + List.length succs; - list_iter_with add_live t succs) + m.expansion_edges_scanned + ReactiveOffheapList.length succs; + ReactiveOffheapList.iter_with add_live t succs) done; ReactiveSet.iter_with (fun t k -> emit_removal t (ReactiveAllocator.unsafe_from_offheap k) ()) diff --git a/analysis/reactive/src/ReactiveMaybe.ml b/analysis/reactive/src/ReactiveMaybe.ml index 5b17b977a9f..3502f1e227c 100644 --- a/analysis/reactive/src/ReactiveMaybe.ml +++ b/analysis/reactive/src/ReactiveMaybe.ml @@ -23,5 +23,9 @@ let[@inline] maybe_unit_to_offheap (x : unit t) : unit t ReactiveAllocator.offheap = ReactiveAllocator.unsafe_to_offheap x +let[@inline] maybe_offheap_list_to_offheap + (x : 'a ReactiveOffheapList.t t) : 'a list t ReactiveAllocator.offheap = + ReactiveAllocator.unsafe_to_offheap x + let[@inline] to_option (x : 'a t) : 'a option = if x != sentinel then Some (Obj.obj x) else None diff --git a/analysis/reactive/src/ReactiveMaybe.mli b/analysis/reactive/src/ReactiveMaybe.mli index b2451a0eb99..34b27214ead 100644 --- a/analysis/reactive/src/ReactiveMaybe.mli +++ b/analysis/reactive/src/ReactiveMaybe.mli @@ -27,4 +27,9 @@ val maybe_int_to_offheap : int t -> int t ReactiveAllocator.offheap val maybe_unit_to_offheap : unit t -> unit t ReactiveAllocator.offheap (** Safely mark a [unit] maybe value as suitable for off-heap storage. *) +val maybe_offheap_list_to_offheap : + 'a ReactiveOffheapList.t t -> 'a list t ReactiveAllocator.offheap +(** Mark a maybe value carrying an already offheap-marked list as suitable for + storage in an off-heap container with semantic payload type ['a list]. *) + val to_option : 'a t -> 'a option diff --git a/analysis/reactive/src/ReactiveOffheapList.ml b/analysis/reactive/src/ReactiveOffheapList.ml new file mode 100644 index 00000000000..595b256a997 --- /dev/null +++ b/analysis/reactive/src/ReactiveOffheapList.ml @@ -0,0 +1,49 @@ +type 'a inner = 'a list +type 'a t = 'a inner ReactiveAllocator.offheap + +let unsafe_of_list = ReactiveAllocator.unsafe_to_offheap +let of_list = ReactiveAllocator.to_offheap +let list_of = ReactiveAllocator.unsafe_from_offheap +let unsafe_of_offheap_list xs = + unsafe_of_list (ReactiveAllocator.unsafe_from_offheap xs) + +let empty () : 'a t = unsafe_of_list [] + +let is_empty xs = + match list_of xs with + | [] -> true + | _ -> false + +let rec length_list acc = function + | [] -> acc + | _ :: rest -> length_list (acc + 1) rest + +let length xs = length_list 0 (list_of xs) + +let rec iter_list f = function + | [] -> () + | x :: rest -> + f x; + iter_list f rest + +let iter f xs = iter_list f (list_of xs) + +let rec iter_list_with f arg = function + | [] -> () + | x :: rest -> + f arg x; + iter_list_with f arg rest + +let iter_with f arg xs = iter_list_with f arg (list_of xs) + +let rec exists_list f = function + | [] -> false + | x :: rest -> f x || exists_list f rest + +let exists f xs = exists_list f (list_of xs) + +let rec exists_list_with f arg = function + | [] -> false + | x :: rest -> f arg x || exists_list_with f arg rest + +let exists_with f arg xs = exists_list_with f arg (list_of xs) diff --git a/analysis/reactive/src/ReactiveOffheapList.mli b/analysis/reactive/src/ReactiveOffheapList.mli new file mode 100644 index 00000000000..d13fa075f3d --- /dev/null +++ b/analysis/reactive/src/ReactiveOffheapList.mli @@ -0,0 +1,25 @@ +(** Off-heap-marked OCaml lists. + + The list cells are ordinary OCaml heap values. This type makes the + boundary explicit when such a list is stored in an off-heap container. *) + +type 'a inner +type 'a t = 'a inner ReactiveAllocator.offheap + +val unsafe_of_list : 'a list -> 'a t +(** Reinterpret a list as offheap-marked 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 unsafe_of_offheap_list : 'a list ReactiveAllocator.offheap -> 'a t +(** Reinterpret an already offheap-marked list as an offheap-list value. *) + +val empty : unit -> 'a t +val is_empty : 'a t -> bool +val length : 'a t -> int +val iter : ('a -> unit) -> 'a t -> unit +val iter_with : ('b -> 'a -> unit) -> 'b -> 'a t -> unit +val exists : ('a -> bool) -> 'a t -> bool +val exists_with : ('b -> 'a -> bool) -> 'b -> 'a t -> bool diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index b7e1a784de0..741f201ac1a 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -353,6 +353,7 @@ 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_offheap = Array.map ReactiveOffheapList.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 @@ -361,7 +362,8 @@ let test_reactive_fixpoint_alloc_n n = ReactiveWave.clear edge_wave; for i = 0 to n - 2 do ReactiveWave.push edge_wave (off_int i) - (ReactiveAllocator.to_offheap (ReactiveMaybe.some edge_values.(i))) + (ReactiveMaybe.maybe_offheap_list_to_offheap + (ReactiveMaybe.some edge_values_offheap.(i))) done; emit_edges edge_wave; let reachable = Reactive.Fixpoint.create ~name:"reachable" ~init ~edges () in diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 8cdd8093c95..81afb2729f2 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -59,8 +59,8 @@ let test_batch_fixpoint () = fp; (* Set up edges first *) - emit_set emit_edges "a" ["b"; "c"]; - emit_set emit_edges "b" ["d"]; + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "b" ["d"]; (* Send batch of roots *) emit_sets emit_init [("a", ()); ("x", ())]; diff --git a/analysis/reactive/test/FixpointBasicTest.ml b/analysis/reactive/test/FixpointBasicTest.ml index 4af0db689d4..afe700f8b53 100644 --- a/analysis/reactive/test/FixpointBasicTest.ml +++ b/analysis/reactive/test/FixpointBasicTest.ml @@ -11,9 +11,9 @@ let test_fixpoint () = let edges, emit_edges = Source.create ~name:"edges" () in (* Set up graph: 1 -> [2, 3], 2 -> [4], 3 -> [4] *) - emit_set emit_edges 1 [2; 3]; - emit_set emit_edges 2 [4]; - emit_set emit_edges 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.create ~name:"reachable" ~init ~edges () in @@ -34,7 +34,7 @@ let test_fixpoint () = assert (get_opt reachable 5 = None); (* Add another root 5 with edge 5 -> [6] *) - emit_set emit_edges 5 [6]; + 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); @@ -60,8 +60,8 @@ let test_fixpoint_basic_expansion () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -83,8 +83,8 @@ let test_fixpoint_multiple_roots () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, c -> d (disconnected components) *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "c" ["d"]; + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "c" ["d"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -107,9 +107,9 @@ let test_fixpoint_diamond () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, a -> c, b -> d, c -> d *) - emit_set emit_edges "a" ["b"; "c"]; - emit_set emit_edges "b" ["d"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in @@ -127,9 +127,9 @@ let test_fixpoint_cycle () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c -> b (cycle from root) *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "b" ["c"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in @@ -149,7 +149,7 @@ let test_fixpoint_empty_base () = let init, _emit_init = Source.create ~name:"init" () in let edges, emit_edges = Source.create ~name:"edges" () in - emit_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "a" ["b"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -165,7 +165,7 @@ let test_fixpoint_self_loop () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> a (self loop) *) - emit_set emit_edges "a" ["a"]; + emit_edge_set emit_edges "a" ["a"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -185,8 +185,8 @@ let test_fixpoint_existing_data () = emit_set emit_init "root" (); let edges, emit_edges = Source.create ~name:"edges" () in - emit_set emit_edges "root" ["a"; "b"]; - emit_set emit_edges "a" ["c"]; + 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.create ~name:"fp" ~init ~edges () in diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/FixpointIncrementalTest.ml index bee3883e8fa..497a7556381 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -11,8 +11,8 @@ let test_fixpoint_add_base () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b, c -> d *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "c" ["d"]; + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "c" ["d"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -53,8 +53,8 @@ let test_fixpoint_remove_base () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -102,7 +102,7 @@ let test_fixpoint_add_edge () = fp; (* Add edge a -> b *) - emit_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "a" ["b"]; Printf.printf "Added: [%s]\n" (String.concat ", " !added); assert (List.mem "b" !added); @@ -118,8 +118,8 @@ let test_fixpoint_remove_edge () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "b" ["c"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -137,7 +137,7 @@ let test_fixpoint_remove_edge () = fp; (* remove edge a -> b *) - emit_set emit_edges "a" []; + emit_edge_set emit_edges "a" []; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (List.length !removed = 2); @@ -155,9 +155,9 @@ let test_fixpoint_cycle_removal () = let edges, emit_edges = Source.create ~name:"edges" () in (* Graph: a -> b -> c -> b (b-c cycle reachable from a) *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "b" ["c"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in @@ -175,7 +175,7 @@ let test_fixpoint_cycle_removal () = fp; (* remove edge a -> b *) - emit_set emit_edges "a" []; + 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 *) @@ -196,8 +196,8 @@ let test_fixpoint_alternative_support () = (* Graph: a -> b, a -> c -> b If we remove a -> b, b should survive via a -> c -> b *) - emit_set emit_edges "a" ["b"; "c"]; - emit_set emit_edges "c" ["b"]; + emit_edge_set emit_edges "a" ["b"; "c"]; + emit_edge_set emit_edges "c" ["b"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -215,7 +215,7 @@ let test_fixpoint_alternative_support () = fp; (* remove direct edge a -> b (but keep a -> c) *) - emit_set emit_edges "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 *) @@ -231,8 +231,8 @@ let test_fixpoint_deltas () = let init, emit_init = Source.create ~name:"init" () in let edges, emit_edges = Source.create ~name:"edges" () in - emit_set emit_edges 1 [2; 3]; - emit_set emit_edges 2 [4]; + emit_edge_set emit_edges 1 [2; 3]; + emit_edge_set emit_edges 2 [4]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -252,7 +252,7 @@ let test_fixpoint_deltas () = all_entries := []; (* Add edge 3 -> 5 *) - emit_set emit_edges 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); @@ -306,7 +306,7 @@ let test_fixpoint_remove_spurious_root () = String.concat ", " (List.sort String.compare !items)); (* Step 3: Edge root -> a is added *) - emit_set emit_edges "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; @@ -314,7 +314,7 @@ let test_fixpoint_remove_spurious_root () = assert (get_opt fp "a" = Some ()); (* Step 4: Edge a -> b is added *) - emit_set emit_edges "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; @@ -350,8 +350,8 @@ let test_fixpoint_remove_edge_entry_alternative_source () = let edges, emit_edges = Source.create ~name:"edges" () in (* Set up initial edges: a -> b, c -> b *) - emit_set emit_edges "a" ["b"]; - emit_set emit_edges "c" ["b"]; + emit_edge_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "c" ["b"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -420,9 +420,9 @@ let test_fixpoint_remove_edge_rederivation () = emit_set emit_init "root" (); (* Build graph: root -> a -> b -> c, a -> c *) - emit_set emit_edges "root" ["a"]; - emit_set emit_edges "a" ["b"; "c"]; - emit_set emit_edges "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 @@ -435,7 +435,7 @@ let test_fixpoint_remove_edge_rederivation () = added := []; (* remove the direct edge a -> c *) - emit_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "a" ["b"]; Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in @@ -459,8 +459,8 @@ let test_fixpoint_remove_edge_entry_rederivation () = let edges, emit_edges = Source.create ~name:"edges" () in (* Set up edges before creating fixpoint *) - emit_set emit_edges "a" ["c"]; - emit_set emit_edges "b" ["c"]; + emit_edge_set emit_edges "a" ["c"]; + emit_edge_set emit_edges "b" ["c"]; let fp = Fixpoint.create ~name:"fp" ~init ~edges () in @@ -529,9 +529,9 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = emit_set emit_init "root" (); (* Build graph: root -> a -> b -> c, a -> c *) - emit_set emit_edges "root" ["a"]; - emit_set emit_edges "a" ["b"; "c"]; - emit_set emit_edges "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 @@ -545,7 +545,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = added := []; (* remove direct edge a -> c, keeping a -> b *) - emit_set emit_edges "a" ["b"]; + emit_edge_set emit_edges "a" ["b"]; Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in @@ -570,11 +570,11 @@ let test_fixpoint_remove_edge_entry_needs_rederivation () = let edges, emit_edges = Source.create ~name:"edges" () in (* Pre-populate edges so fixpoint initializes with them *) - emit_set emit_edges "r" ["a"; "b"]; - emit_set emit_edges "a" ["y"]; - emit_set emit_edges "b" ["c"]; - emit_set emit_edges "c" ["x"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in @@ -614,12 +614,12 @@ let test_fixpoint_remove_base_needs_rederivation () = let edges, emit_edges = Source.create ~name:"edges" () in (* Pre-populate edges so fixpoint initializes with them *) - emit_set emit_edges "r1" ["a"]; - emit_set emit_edges "a" ["y"]; - emit_set emit_edges "r2" ["b"]; - emit_set emit_edges "b" ["c"]; - emit_set emit_edges "c" ["x"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in @@ -656,10 +656,10 @@ let test_fixpoint_batch_overlapping_deletions () = let edges, emit_edges = Source.create ~name:"edges" () in (* r -> a,b ; a -> x ; b -> x ; x -> y *) - emit_set emit_edges "r" ["a"; "b"]; - emit_set emit_edges "a" ["x"]; - emit_set emit_edges "b" ["x"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); @@ -678,7 +678,7 @@ let test_fixpoint_batch_overlapping_deletions () = fp; (* remove both supports for x in one batch. *) - emit_batch emit_edges [("a", Some []); ("b", Some [])]; + emit_edge_batch emit_edges [("a", Some []); ("b", Some [])]; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (List.mem "x" !removed); @@ -699,9 +699,9 @@ let test_fixpoint_batch_delete_add_same_wave () = let edges, emit_edges = Source.create ~name:"edges" () in (* r -> a,c ; a -> x ; c -> [] *) - emit_set emit_edges "r" ["a"; "c"]; - emit_set emit_edges "a" ["x"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); @@ -722,7 +722,7 @@ let test_fixpoint_batch_delete_add_same_wave () = fp; (* In one batch: remove a->x and add c->x. x should stay live. *) - emit_batch emit_edges [("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) @@ -743,10 +743,10 @@ let test_fixpoint_fanin_single_predecessor_removed () = let edges, emit_edges = Source.create ~name:"edges" () in (* r -> a,b,c ; a,b,c -> z *) - emit_set emit_edges "r" ["a"; "b"; "c"]; - emit_set emit_edges "a" ["z"]; - emit_set emit_edges "b" ["z"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); @@ -765,7 +765,7 @@ let test_fixpoint_fanin_single_predecessor_removed () = fp; (* remove only one predecessor contribution; z should remain live. *) - emit_set emit_edges "a" []; + emit_edge_set emit_edges "a" []; Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); assert (get_opt fp "z" = Some ()); @@ -783,10 +783,10 @@ let test_fixpoint_cycle_alternative_external_support () = let edges, emit_edges = Source.create ~name:"edges" () in (* r1 -> b ; r2 -> c ; b <-> c *) - emit_set emit_edges "r1" ["b"]; - emit_set emit_edges "r2" ["c"]; - emit_set emit_edges "b" ["c"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in emit_set emit_init "r1" (); @@ -806,7 +806,7 @@ let test_fixpoint_cycle_alternative_external_support () = fp; (* remove one external support edge; cycle should remain via r2 -> c. *) - emit_set emit_edges "r1" []; + emit_edge_set emit_edges "r1" []; Printf.printf "After removing r1->b, removed: [%s]\n" (String.concat ", " !removed); @@ -817,7 +817,7 @@ let test_fixpoint_cycle_alternative_external_support () = removed := []; (* remove the other external support edge; cycle should now disappear. *) - emit_set emit_edges "r2" []; + emit_edge_set emit_edges "r2" []; Printf.printf "After removing r2->c, removed: [%s]\n" (String.concat ", " !removed); @@ -839,9 +839,9 @@ let test_fixpoint_remove_then_readd_via_expansion_same_wave () = (* 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_set emit_edges "r" ["s"]; - emit_set emit_edges "s" ["x"]; - emit_set emit_edges "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.create ~name:"fp" ~init ~edges () in emit_set emit_init "r" (); @@ -862,7 +862,7 @@ let test_fixpoint_remove_then_readd_via_expansion_same_wave () = entries) fp; - emit_set emit_edges "s" ["y"]; + emit_edge_set emit_edges "s" ["y"]; Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index e2a9c7eec41..9024c67cf82 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -21,6 +21,17 @@ let emit_set emit k v = (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)); emit w +(** Emit a single edge-set entry, converting the successor list to the + explicit offheap-list type. *) +let emit_edge_set emit k vs = + let w = wave () in + ReactiveWave.clear w; + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveMaybe.maybe_offheap_list_to_offheap + (ReactiveMaybe.some (ReactiveOffheapList.unsafe_of_list vs))); + emit w + (** Emit a single remove entry *) let emit_remove emit k = let w = wave () in @@ -60,6 +71,25 @@ let emit_batch emit entries = entries; emit w +(** Emit a batch of edge entries using the explicit offheap-list type. *) +let emit_edge_batch emit entries = + let w = wave () in + ReactiveWave.clear w; + List.iter + (fun (k, vs_opt) -> + match vs_opt with + | Some vs -> + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) + (ReactiveMaybe.maybe_offheap_list_to_offheap + (ReactiveMaybe.some (ReactiveOffheapList.unsafe_of_list vs))) + | None -> + ReactiveWave.push w + (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMaybe.none_offheap) + entries; + emit w + (** {1 Compatibility helpers} *) (* subscribe takes collection first in V2, but we want handler first for compatibility *) diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index a50e02d654e..247e037607e 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -40,7 +40,8 @@ let create ~(merged : ReactiveMerge.t) : t = Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index ~f:(fun pos (value_targets, type_targets) emit -> let all_targets = PosSet.union value_targets type_targets in - emit pos (PosSet.elements all_targets)) + emit pos + (ReactiveOffheapList.unsafe_of_list (PosSet.elements all_targets))) () in From 83845a39cd914053982e2da05a400eb496de91b7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 7 Mar 2026 12:08:29 +0100 Subject: [PATCH 21/54] analysis/reactive: move fixpoint successor maps off heap --- analysis/reactive/src/Reactive.ml | 3 +- analysis/reactive/src/ReactiveFixpoint.ml | 104 ++++++++++++---------- analysis/reactive/src/ReactiveMaybe.ml | 4 +- 3 files changed, 59 insertions(+), 52 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index d293c9264bf..c352ca54787 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -835,8 +835,7 @@ module Fixpoint = struct let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in - let edge_pending : - ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = + let edge_pending : ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in let init_pending_count = ref 0 in diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 5b941e7f21a..9b30a25bedf 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -17,7 +17,7 @@ type 'k metrics_state = { type 'k t = { current: 'k ReactiveSet.t; - edge_map: ('k, 'k ReactiveOffheapList.t) ReactiveHash.Map.t; + edge_map: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; roots: 'k ReactiveSet.t; output_wave: ('k, unit ReactiveMaybe.t) ReactiveWave.t; @@ -25,8 +25,8 @@ type 'k t = { deleted_nodes: 'k ReactiveSet.t; rederive_pending: 'k ReactiveSet.t; expansion_seen: 'k ReactiveSet.t; - old_successors_for_changed: ('k, 'k ReactiveOffheapList.t) ReactiveHash.Map.t; - new_successors_for_changed: ('k, 'k ReactiveOffheapList.t) ReactiveHash.Map.t; + old_successors_for_changed: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; + new_successors_for_changed: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; (* Scratch sets for analyze_edge_change / apply_edge_update *) scratch_set_a: 'k ReactiveSet.t; scratch_set_b: 'k ReactiveSet.t; @@ -55,8 +55,6 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = let[@inline] off_key k = ReactiveAllocator.unsafe_to_offheap k let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) -let[@inline] pop_key q = - ReactiveAllocator.unsafe_from_offheap (ReactiveFifo.pop q) (* Full-reachability BFS into [visited]. Returns (node_work, edge_work). [visited] is cleared before use; zero allocation when [visited] is @@ -83,9 +81,9 @@ let compute_reachable ~visited t = ()) (visited, frontier) t.roots; while not (ReactiveFifo.is_empty frontier) do - let k = pop_key frontier in + let k = ReactiveFifo.pop frontier in incr node_work; - let r = ReactiveHash.Map.find_maybe t.edge_map k in + let r = ReactiveMap.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( let succs = ReactiveMaybe.unsafe_get r in edge_work := !edge_work + ReactiveOffheapList.length succs; @@ -256,7 +254,10 @@ module Invariants = struct (* Drain and re-push to iterate without consuming *) let items = ref [] in while not (ReactiveFifo.is_empty edge_change_queue) do - let src = pop_key edge_change_queue in + let src = + ReactiveAllocator.unsafe_from_offheap + (ReactiveFifo.pop edge_change_queue) + in items := src :: !items; enqueue q_copy src done; @@ -267,14 +268,14 @@ module Invariants = struct List.iter (fun src -> let r_old = - ReactiveHash.Map.find_maybe old_successors_for_changed src + ReactiveMap.find_maybe old_successors_for_changed (off_key src) in let old_succs = if ReactiveMaybe.is_some r_old then ReactiveMaybe.unsafe_get r_old else ReactiveOffheapList.empty () in let r_new = - ReactiveHash.Map.find_maybe new_successors_for_changed src + ReactiveMap.find_maybe new_successors_for_changed (off_key src) in let new_succs = if ReactiveMaybe.is_some r_new then ReactiveMaybe.unsafe_get r_new @@ -408,14 +409,14 @@ let create ~max_nodes ~max_edges = invalid_arg "ReactiveFixpoint.create: max_edges must be > 0"; { current = ReactiveSet.create (); - edge_map = ReactiveHash.Map.create (); + edge_map = ReactiveMap.create (); pred_map = ReactivePoolMapSet.create ~capacity:128; roots = ReactiveSet.create (); output_wave = ReactiveWave.create ~max_entries:max_nodes (); deleted_nodes = ReactiveSet.create (); rederive_pending = ReactiveSet.create (); expansion_seen = ReactiveSet.create (); - old_successors_for_changed = ReactiveHash.Map.create (); + old_successors_for_changed = ReactiveMap.create (); scratch_set_a = ReactiveSet.create (); scratch_set_b = ReactiveSet.create (); edge_has_new = ReactiveSet.create (); @@ -424,7 +425,7 @@ let create ~max_nodes ~max_edges = expansion_queue = ReactiveFifo.create (); added_roots_queue = ReactiveFifo.create (); edge_change_queue = ReactiveFifo.create (); - new_successors_for_changed = ReactiveHash.Map.create (); + new_successors_for_changed = ReactiveMap.create (); metrics = { delete_queue_pops = 0; @@ -440,10 +441,13 @@ let create ~max_nodes ~max_edges = let destroy t = ReactiveSet.destroy t.current; + ReactiveMap.destroy t.edge_map; ReactiveSet.destroy t.roots; ReactiveSet.destroy t.deleted_nodes; ReactiveSet.destroy t.rederive_pending; ReactiveSet.destroy t.expansion_seen; + ReactiveMap.destroy t.old_successors_for_changed; + ReactiveMap.destroy t.new_successors_for_changed; ReactiveSet.destroy t.scratch_set_a; ReactiveSet.destroy t.scratch_set_b; ReactiveSet.destroy t.edge_has_new; @@ -493,7 +497,7 @@ 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 r = ReactiveHash.Map.find_maybe t.edge_map src in + let r = ReactiveMap.find_maybe t.edge_map (off_key src) in let old_successors = if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else ReactiveOffheapList.empty () @@ -501,13 +505,13 @@ let apply_edge_update t ~src ~new_successors = if ReactiveOffheapList.is_empty old_successors && ReactiveOffheapList.is_empty new_successors - then ReactiveHash.Map.remove t.edge_map src + then ReactiveMap.remove t.edge_map (off_key src) else if ReactiveOffheapList.is_empty old_successors then ( ReactiveOffheapList.iter_with add_pred_for_src (t, src) new_successors; - ReactiveHash.Map.replace t.edge_map src new_successors) + ReactiveMap.replace t.edge_map (off_key src) new_successors) else if ReactiveOffheapList.is_empty new_successors then ( ReactiveOffheapList.iter_with remove_pred_for_src (t, src) old_successors; - ReactiveHash.Map.remove t.edge_map src) + ReactiveMap.remove t.edge_map (off_key src)) else ( ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; @@ -530,11 +534,11 @@ let apply_edge_update t ~src ~new_successors = add_pred t ~target ~pred:src) () new_successors; - ReactiveHash.Map.replace t.edge_map src new_successors) + ReactiveMap.replace t.edge_map (off_key src) new_successors) let initialize t ~roots ~edges = ReactiveSet.clear t.roots; - ReactiveHash.Map.clear t.edge_map; + ReactiveMap.clear t.edge_map; ReactivePoolMapSet.clear t.pred_map; ReactiveWave.iter roots (fun k _ -> ReactiveSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> @@ -547,10 +551,10 @@ let is_supported t k = ReactiveSet.mem t.roots (off_key k) || has_live_predecessor t k let old_successors t k = - let r = ReactiveHash.Map.find_maybe t.old_successors_for_changed k in + let r = ReactiveMap.find_maybe t.old_successors_for_changed (off_key k) in if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else - let r2 = ReactiveHash.Map.find_maybe t.edge_map k in + let r2 = ReactiveMap.find_maybe t.edge_map (off_key k) in if ReactiveMaybe.is_some r2 then ReactiveMaybe.unsafe_get r2 else ReactiveOffheapList.empty () @@ -608,7 +612,7 @@ let mark_deleted_unless_in_set t set xs = let exists_not_in_set set xs = ReactiveOffheapList.exists_with not_in_set set xs let scan_edge_entry t src mv = - let r = ReactiveHash.Map.find_maybe t.edge_map src in + let r = ReactiveMap.find_maybe t.edge_map (off_key src) in let old_succs = if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else ReactiveOffheapList.empty () @@ -618,8 +622,8 @@ let scan_edge_entry t src mv = ReactiveOffheapList.unsafe_of_list (ReactiveMaybe.unsafe_get mv) else ReactiveOffheapList.empty () in - ReactiveHash.Map.replace t.old_successors_for_changed src old_succs; - ReactiveHash.Map.replace t.new_successors_for_changed src new_succs; + ReactiveMap.replace t.old_successors_for_changed (off_key src) old_succs; + ReactiveMap.replace t.new_successors_for_changed (off_key src) new_succs; enqueue t.edge_change_queue src; let src_is_live = ReactiveSet.mem t.current (off_key src) in match (old_succs, new_succs) with @@ -650,7 +654,8 @@ let emit_removal t k () = (ReactiveAllocator.unsafe_to_offheap k) ReactiveMaybe.none_offheap -let rebuild_edge_change_queue t src _succs = enqueue t.edge_change_queue src +let rebuild_edge_change_queue t src _succs = + ReactiveFifo.push t.edge_change_queue src let remove_from_current t k = ReactiveSet.remove t.current k @@ -666,8 +671,8 @@ let apply_list t ~roots ~edges = ReactiveFifo.clear t.delete_queue; ReactiveFifo.clear t.added_roots_queue; ReactiveFifo.clear t.edge_change_queue; - ReactiveHash.Map.clear t.old_successors_for_changed; - ReactiveHash.Map.clear t.new_successors_for_changed; + ReactiveMap.clear t.old_successors_for_changed; + ReactiveMap.clear t.new_successors_for_changed; ReactiveSet.clear t.edge_has_new; let m = t.metrics in Metrics.reset_per_call m; @@ -698,7 +703,9 @@ let apply_list t ~roots ~edges = (* Phase 2: delete BFS *) while not (ReactiveFifo.is_empty t.delete_queue) do - let k = pop_key t.delete_queue in + let k = + ReactiveAllocator.unsafe_from_offheap (ReactiveFifo.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; @@ -720,18 +727,19 @@ let apply_list t ~roots ~edges = (* Apply edge updates by draining edge_change_queue. *) while not (ReactiveFifo.is_empty t.edge_change_queue) do - let src = pop_key t.edge_change_queue in - let r = ReactiveHash.Map.find_maybe t.new_successors_for_changed src in + let src = ReactiveFifo.pop t.edge_change_queue in + let r = ReactiveMap.find_maybe t.new_successors_for_changed src in let new_succs = if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r else ReactiveOffheapList.empty () in - apply_edge_update t ~src ~new_successors:new_succs + apply_edge_update t + ~src:(ReactiveAllocator.unsafe_from_offheap src) + ~new_successors:new_succs done; (* Rebuild edge_change_queue from new_successors_for_changed keys for use in expansion seeding below *) - ReactiveHash.Map.iter_with rebuild_edge_change_queue t - t.new_successors_for_changed; + ReactiveMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; ReactiveSet.iter_with remove_from_current t t.deleted_nodes; (match pre_current with @@ -750,17 +758,17 @@ let apply_list t ~roots ~edges = t t.deleted_nodes; while not (ReactiveFifo.is_empty t.rederive_queue) do - let k = pop_key t.rederive_queue in + let k = ReactiveFifo.pop t.rederive_queue in if Metrics.enabled then m.rederive_queue_pops <- m.rederive_queue_pops + 1; - ReactiveSet.remove t.rederive_pending (off_key k); + ReactiveSet.remove t.rederive_pending k; if - ReactiveSet.mem t.deleted_nodes (off_key k) - && (not (ReactiveSet.mem t.current (off_key k))) - && is_supported t k + ReactiveSet.mem t.deleted_nodes k + && (not (ReactiveSet.mem t.current k)) + && is_supported t (ReactiveAllocator.unsafe_from_offheap k) then ( - ReactiveSet.add t.current (off_key k); + ReactiveSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; - let r = ReactiveHash.Map.find_maybe t.edge_map k in + let r = ReactiveMap.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( let succs = ReactiveMaybe.unsafe_get r in if Metrics.enabled then @@ -778,22 +786,22 @@ let apply_list t ~roots ~edges = (* Seed expansion from added roots *) while not (ReactiveFifo.is_empty t.added_roots_queue) do - add_live t (pop_key t.added_roots_queue) + add_live t + (ReactiveAllocator.unsafe_from_offheap + (ReactiveFifo.pop t.added_roots_queue)) done; (* Seed expansion from edge changes with new edges *) while not (ReactiveFifo.is_empty t.edge_change_queue) do - let src = pop_key t.edge_change_queue in - if - ReactiveSet.mem t.current (off_key src) - && ReactiveSet.mem t.edge_has_new (off_key src) - then enqueue_expand t src + let src = ReactiveFifo.pop t.edge_change_queue in + if ReactiveSet.mem t.current src && ReactiveSet.mem t.edge_has_new src then + enqueue_expand t (ReactiveAllocator.unsafe_from_offheap src) done; while not (ReactiveFifo.is_empty t.expansion_queue) do - let k = pop_key t.expansion_queue in + let k = ReactiveFifo.pop t.expansion_queue in if Metrics.enabled then m.expansion_queue_pops <- m.expansion_queue_pops + 1; - let r = ReactiveHash.Map.find_maybe t.edge_map k in + let r = ReactiveMap.find_maybe t.edge_map k in if ReactiveMaybe.is_some r then ( let succs = ReactiveMaybe.unsafe_get r in if Metrics.enabled then diff --git a/analysis/reactive/src/ReactiveMaybe.ml b/analysis/reactive/src/ReactiveMaybe.ml index 3502f1e227c..958df9245f8 100644 --- a/analysis/reactive/src/ReactiveMaybe.ml +++ b/analysis/reactive/src/ReactiveMaybe.ml @@ -23,8 +23,8 @@ let[@inline] maybe_unit_to_offheap (x : unit t) : unit t ReactiveAllocator.offheap = ReactiveAllocator.unsafe_to_offheap x -let[@inline] maybe_offheap_list_to_offheap - (x : 'a ReactiveOffheapList.t t) : 'a list t ReactiveAllocator.offheap = +let[@inline] maybe_offheap_list_to_offheap (x : 'a ReactiveOffheapList.t t) : + 'a list t ReactiveAllocator.offheap = ReactiveAllocator.unsafe_to_offheap x let[@inline] to_option (x : 'a t) : 'a option = From e61320fbdff852bbaef5441f1f6dee1a3f4a8b41 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 7 Mar 2026 12:19:24 +0100 Subject: [PATCH 22/54] analysis/reactive: rename allocator and maybe modules --- .../{ReactiveAllocator.ml => Allocator.ml} | 18 +-- .../{ReactiveAllocator.mli => Allocator.mli} | 0 .../reactive/src/CONVERTING_COMBINATORS.md | 10 +- .../src/{ReactiveMaybe.ml => Maybe.ml} | 16 +-- .../src/{ReactiveMaybe.mli => Maybe.mli} | 8 +- analysis/reactive/src/POOL_MAP_MAP.md | 2 +- analysis/reactive/src/Reactive.ml | 42 +++--- analysis/reactive/src/Reactive.mli | 14 +- analysis/reactive/src/ReactiveFifo.ml | 36 +++-- analysis/reactive/src/ReactiveFifo.mli | 4 +- .../reactive/src/ReactiveFileCollection.ml | 20 +-- analysis/reactive/src/ReactiveFixpoint.ml | 124 ++++++++---------- analysis/reactive/src/ReactiveFixpoint.mli | 8 +- analysis/reactive/src/ReactiveFlatMap.ml | 52 ++++---- analysis/reactive/src/ReactiveFlatMap.mli | 9 +- analysis/reactive/src/ReactiveHash.ml | 4 +- analysis/reactive/src/ReactiveHash.mli | 2 +- analysis/reactive/src/ReactiveJoin.ml | 107 +++++++-------- analysis/reactive/src/ReactiveJoin.mli | 16 +-- analysis/reactive/src/ReactiveMap.ml | 109 +++++++-------- analysis/reactive/src/ReactiveMap.mli | 20 +-- analysis/reactive/src/ReactiveOffheapList.ml | 10 +- analysis/reactive/src/ReactiveOffheapList.mli | 4 +- analysis/reactive/src/ReactivePoolMapMap.ml | 17 ++- analysis/reactive/src/ReactivePoolMapMap.mli | 2 +- analysis/reactive/src/ReactivePoolMapSet.ml | 10 +- analysis/reactive/src/ReactivePoolMapSet.mli | 2 +- analysis/reactive/src/ReactiveSet.ml | 68 +++++----- analysis/reactive/src/ReactiveSet.mli | 11 +- analysis/reactive/src/ReactiveTable.ml | 37 +++--- analysis/reactive/src/ReactiveTable.mli | 8 +- analysis/reactive/src/ReactiveUnion.ml | 123 ++++++++--------- analysis/reactive/src/ReactiveUnion.mli | 14 +- analysis/reactive/src/ReactiveWave.ml | 42 +++--- analysis/reactive/src/ReactiveWave.mli | 14 +- analysis/reactive/test/AllocTest.ml | 100 ++++++-------- analysis/reactive/test/BatchTest.ml | 3 +- .../reactive/test/FixpointIncrementalTest.ml | 36 ++--- analysis/reactive/test/GlitchFreeTest.ml | 16 +-- analysis/reactive/test/JoinTest.ml | 7 +- analysis/reactive/test/TableTest.ml | 33 ++--- analysis/reactive/test/TestHelpers.ml | 44 +++---- analysis/reanalyze/src/AnnotationStore.ml | 11 +- analysis/reanalyze/src/DeadCommon.ml | 4 +- analysis/reanalyze/src/DeclarationStore.ml | 2 +- analysis/reanalyze/src/ReactiveDeclRefs.ml | 15 +-- .../reanalyze/src/ReactiveExceptionRefs.ml | 4 +- analysis/reanalyze/src/ReactiveLiveness.ml | 8 +- analysis/reanalyze/src/ReactiveSolver.ml | 27 ++-- analysis/reanalyze/src/ReactiveTypeDeps.ml | 16 +-- analysis/reanalyze/src/Reanalyze.ml | 3 +- 51 files changed, 596 insertions(+), 716 deletions(-) rename analysis/reactive/src/{ReactiveAllocator.ml => Allocator.ml} (82%) rename analysis/reactive/src/{ReactiveAllocator.mli => Allocator.mli} (100%) rename analysis/reactive/src/{ReactiveMaybe.ml => Maybe.ml} (65%) rename analysis/reactive/src/{ReactiveMaybe.mli => Maybe.mli} (80%) diff --git a/analysis/reactive/src/ReactiveAllocator.ml b/analysis/reactive/src/Allocator.ml similarity index 82% rename from analysis/reactive/src/ReactiveAllocator.ml rename to analysis/reactive/src/Allocator.ml index fe4395d1dda..a0f56a794fa 100644 --- a/analysis/reactive/src/ReactiveAllocator.ml +++ b/analysis/reactive/src/Allocator.ml @@ -23,7 +23,7 @@ let int_to_offheap x = unsafe_to_offheap x let unit_to_offheap x = unsafe_to_offheap x let to_offheap x = - if is_in_minor_heap x then invalid_arg "ReactiveAllocator.to_offheap"; + if is_in_minor_heap x then invalid_arg "Allocator.to_offheap"; unsafe_to_offheap x module Block = struct @@ -49,31 +49,31 @@ module Block = struct [@@noalloc] let create ~capacity = - check_non_negative "ReactiveAllocator.Block.create" capacity; + check_non_negative "Allocator.Block.create" capacity; create_unsafe capacity let resize block ~capacity = - check_non_negative "ReactiveAllocator.Block.resize" 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 "ReactiveAllocator.Block.get"; + 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 "ReactiveAllocator.Block.set"; + 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 "ReactiveAllocator.Block.blit" src_pos; - check_non_negative "ReactiveAllocator.Block.blit" dst_pos; - check_non_negative "ReactiveAllocator.Block.blit" 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 "ReactiveAllocator.Block.blit"; + invalid_arg "Allocator.Block.blit"; blit_unsafe src src_pos dst dst_pos len end diff --git a/analysis/reactive/src/ReactiveAllocator.mli b/analysis/reactive/src/Allocator.mli similarity index 100% rename from analysis/reactive/src/ReactiveAllocator.mli rename to analysis/reactive/src/Allocator.mli diff --git a/analysis/reactive/src/CONVERTING_COMBINATORS.md b/analysis/reactive/src/CONVERTING_COMBINATORS.md index b289ef5757c..873b64336f1 100644 --- a/analysis/reactive/src/CONVERTING_COMBINATORS.md +++ b/analysis/reactive/src/CONVERTING_COMBINATORS.md @@ -96,17 +96,17 @@ static top-level function (no closure record needed). Available on `ReactiveHash.Map`, `ReactiveHash.Set`, `ReactiveWave`, and as `list_iter_with` for `'a list`. -### Use `ReactiveMaybe` instead of `option` for lookups +### Use `Maybe` instead of `option` for lookups -`ReactiveHash.Map.find_maybe` returns a `ReactiveMaybe.t` — an +`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 ReactiveMaybe.is_some r then - use (ReactiveMaybe.unsafe_get r) +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 @@ -152,7 +152,7 @@ instance. ### `unit option` is already unboxed OCaml represents `Some ()` identically to `()` at runtime — no -allocation. Switching `unit option` to `ReactiveMaybe.t` does not +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. diff --git a/analysis/reactive/src/ReactiveMaybe.ml b/analysis/reactive/src/Maybe.ml similarity index 65% rename from analysis/reactive/src/ReactiveMaybe.ml rename to analysis/reactive/src/Maybe.ml index 958df9245f8..d76471bf2b3 100644 --- a/analysis/reactive/src/ReactiveMaybe.ml +++ b/analysis/reactive/src/Maybe.ml @@ -10,22 +10,20 @@ let sentinel_words = 257 let sentinel : Obj.t = Obj.repr (Array.make sentinel_words 0) let none = sentinel -let none_offheap = ReactiveAllocator.to_offheap none +let none_offheap = Allocator.to_offheap 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] maybe_int_to_offheap (x : int t) : int t ReactiveAllocator.offheap - = - ReactiveAllocator.unsafe_to_offheap x +let[@inline] maybe_int_to_offheap (x : int t) : int t Allocator.offheap = + Allocator.unsafe_to_offheap x -let[@inline] maybe_unit_to_offheap (x : unit t) : - unit t ReactiveAllocator.offheap = - ReactiveAllocator.unsafe_to_offheap x +let[@inline] maybe_unit_to_offheap (x : unit t) : unit t Allocator.offheap = + Allocator.unsafe_to_offheap x let[@inline] maybe_offheap_list_to_offheap (x : 'a ReactiveOffheapList.t t) : - 'a list t ReactiveAllocator.offheap = - ReactiveAllocator.unsafe_to_offheap x + 'a list t Allocator.offheap = + Allocator.unsafe_to_offheap x let[@inline] to_option (x : 'a t) : 'a option = if x != sentinel then Some (Obj.obj x) else None diff --git a/analysis/reactive/src/ReactiveMaybe.mli b/analysis/reactive/src/Maybe.mli similarity index 80% rename from analysis/reactive/src/ReactiveMaybe.mli rename to analysis/reactive/src/Maybe.mli index 34b27214ead..ba4b92deac7 100644 --- a/analysis/reactive/src/ReactiveMaybe.mli +++ b/analysis/reactive/src/Maybe.mli @@ -12,7 +12,7 @@ type 'a t val none : 'a t (** Unique sentinel representing the absent case. *) -val none_offheap : 'a t ReactiveAllocator.offheap +val none_offheap : 'a t Allocator.offheap (** Off-heap-marked form of [none]. Safe because the sentinel is allocated outside the minor heap and kept reachable for the lifetime of the process. *) @@ -21,14 +21,14 @@ val is_none : 'a t -> bool val is_some : 'a t -> bool val unsafe_get : 'a t -> 'a -val maybe_int_to_offheap : int t -> int t ReactiveAllocator.offheap +val maybe_int_to_offheap : int t -> int t Allocator.offheap (** Safely mark an [int] maybe value as suitable for off-heap storage. *) -val maybe_unit_to_offheap : unit t -> unit t ReactiveAllocator.offheap +val maybe_unit_to_offheap : unit t -> unit t Allocator.offheap (** Safely mark a [unit] maybe value as suitable for off-heap storage. *) val maybe_offheap_list_to_offheap : - 'a ReactiveOffheapList.t t -> 'a list t ReactiveAllocator.offheap + 'a ReactiveOffheapList.t t -> 'a list t Allocator.offheap (** Mark a maybe value carrying an already offheap-marked list as suitable for storage in an off-heap container with semantic payload type ['a list]. *) diff --git a/analysis/reactive/src/POOL_MAP_MAP.md b/analysis/reactive/src/POOL_MAP_MAP.md index 198c0f2ed38..ac75e289c7e 100644 --- a/analysis/reactive/src/POOL_MAP_MAP.md +++ b/analysis/reactive/src/POOL_MAP_MAP.md @@ -92,7 +92,7 @@ val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko -> int val outer_cardinal : ('ko, 'ki, 'v) t -> int val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t ReactiveMaybe.t + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t (** Optional: keep internal/private if we want stricter discipline. *) val tighten : ('ko, 'ki, 'v) t -> unit diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index c352ca54787..a4968e83909 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -9,7 +9,7 @@ (** {1 Waves} *) -type ('k, 'v) wave = ('k, 'v ReactiveMaybe.t) ReactiveWave.t +type ('k, 'v) wave = ('k, 'v Maybe.t) ReactiveWave.t let create_wave () = ReactiveWave.create () @@ -455,7 +455,7 @@ type ('k, 'v) t = { name: string; subscribe: (('k, 'v) wave -> unit) -> unit; iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v ReactiveMaybe.t; + get: 'k -> 'v Maybe.t; length: unit -> int; destroy: unit -> unit; stats: stats; @@ -473,27 +473,27 @@ let name t = t.name let unsafe_wave_push wave k v = ReactiveWave.push wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap v) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap v) (** {1 Source Collection} *) module Source = struct type ('k, 'v) tables = { tbl: ('k, 'v) ReactiveHash.Map.t; - pending: ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t; + pending: ('k, 'v Maybe.t) ReactiveHash.Map.t; } let apply_emit (tables : ('k, 'v) tables) k mv = - let k = ReactiveAllocator.unsafe_from_offheap k in - let mv = ReactiveAllocator.unsafe_from_offheap mv in - if ReactiveMaybe.is_some mv then ( - let v = ReactiveMaybe.unsafe_get mv in + let k = Allocator.unsafe_from_offheap k in + let mv = Allocator.unsafe_from_offheap mv in + if Maybe.is_some mv then ( + let v = Maybe.unsafe_get mv in ReactiveHash.Map.replace tables.tbl k v; - ReactiveHash.Map.replace tables.pending k (ReactiveMaybe.some v)) + ReactiveHash.Map.replace tables.pending k (Maybe.some v)) else ( ReactiveHash.Map.remove tables.tbl k; - ReactiveHash.Map.replace tables.pending k ReactiveMaybe.none) + ReactiveHash.Map.replace tables.pending k Maybe.none) let create ~name () = let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.create () in @@ -502,7 +502,7 @@ module Source = struct let output_wave = create_wave () in (* Pending deltas: accumulated by emit, flushed by process. Uses ReactiveHash.Map for zero-alloc deduplication (last-write-wins). *) - let pending : ('k, 'v ReactiveMaybe.t) ReactiveHash.Map.t = + let pending : ('k, 'v Maybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in let tables = {tbl; pending} in @@ -539,7 +539,7 @@ module Source = struct } in - let emit (input_wave : ('k, 'v ReactiveMaybe.t) ReactiveWave.t) = + let emit (input_wave : ('k, 'v Maybe.t) ReactiveWave.t) = let count = ReactiveWave.count input_wave in my_stats.deltas_received <- my_stats.deltas_received + 1; my_stats.entries_received <- my_stats.entries_received + count; @@ -801,8 +801,8 @@ end module Fixpoint = struct let unsafe_wave_map_replace pending k v = ReactiveHash.Map.replace pending - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v) + (Allocator.unsafe_from_offheap k) + (Allocator.unsafe_from_offheap v) let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = @@ -832,10 +832,10 @@ module Fixpoint = struct let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries () in let subscribers = ref [] in let my_stats = create_stats () in - let root_pending : ('k, unit ReactiveMaybe.t) ReactiveHash.Map.t = + let root_pending : ('k, unit Maybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in - let edge_pending : ('k, 'k list ReactiveMaybe.t) ReactiveHash.Map.t = + let edge_pending : ('k, 'k list Maybe.t) ReactiveHash.Map.t = ReactiveHash.Map.create () in let init_pending_count = ref 0 in @@ -861,8 +861,8 @@ module Fixpoint = struct ReactiveHash.Map.iter_with (fun wave k mv -> ReactiveWave.push wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap mv)) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap mv)) edge_wave edge_pending; ReactiveHash.Map.clear root_pending; ReactiveHash.Map.clear edge_pending; @@ -920,8 +920,8 @@ module Fixpoint = struct init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); edges.iter (fun k succs -> ReactiveWave.push init_edges_wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap succs)); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap succs)); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; ReactiveWave.destroy init_roots_wave; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index 264e3be8bdf..6b8282946de 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -9,7 +9,7 @@ (** {1 Waves} *) -type ('k, 'v) wave = ('k, 'v ReactiveMaybe.t) ReactiveWave.t +type ('k, 'v) wave = ('k, 'v Maybe.t) ReactiveWave.t (** Mutable wave buffer carrying batch entries *) (** {1 Statistics} *) @@ -76,7 +76,7 @@ type ('k, 'v) t = { name: string; subscribe: (('k, 'v) wave -> unit) -> unit; iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v ReactiveMaybe.t; + get: 'k -> 'v Maybe.t; length: unit -> int; destroy: unit -> unit; stats: stats; @@ -86,7 +86,7 @@ type ('k, 'v) t = { (** 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 ReactiveMaybe.t +val get : ('k, 'v) t -> 'k -> 'v Maybe.t val length : ('k, 'v) t -> int val destroy : ('k, 'v) t -> unit val stats : ('k, 'v) t -> stats @@ -99,11 +99,11 @@ module Source : sig val create : name:string -> unit -> - ('k, 'v) t * (('k, 'v ReactiveMaybe.t) ReactiveWave.t -> unit) + ('k, 'v) t * (('k, 'v Maybe.t) ReactiveWave.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 [ReactiveMaybe.some v] for set - or [ReactiveMaybe.none] for remove. + Each wave entry is a key with [Maybe.some v] for set + or [Maybe.none] for remove. Emitting triggers propagation through the pipeline. *) end @@ -127,7 +127,7 @@ module Join : sig ('k1, 'v1) t -> ('k2, 'v2) t -> key_of:('k1 -> 'v1 -> 'k2) -> - f:('k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> + f:('k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> ?merge:('v3 -> 'v3 -> 'v3) -> unit -> ('k3, 'v3) t diff --git a/analysis/reactive/src/ReactiveFifo.ml b/analysis/reactive/src/ReactiveFifo.ml index 627cc7cec42..613526b5f3b 100644 --- a/analysis/reactive/src/ReactiveFifo.ml +++ b/analysis/reactive/src/ReactiveFifo.ml @@ -1,28 +1,27 @@ (* Representation of ['a t]: - - ['a t] is [('a, int, int) ReactiveAllocator.Block2.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 ReactiveAllocator.offheap]. + - Data slots: queue elements, stored as ['a Allocator.offheap]. 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) ReactiveAllocator.Block2.t +type 'a t = ('a, int, int) Allocator.Block2.t let initial_capacity = 16 -let head = ReactiveAllocator.Block2.get0 -let set_head = ReactiveAllocator.Block2.set0 -let tail = ReactiveAllocator.Block2.get1 -let set_tail = ReactiveAllocator.Block2.set1 -let slot_capacity = ReactiveAllocator.Block2.capacity +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 () = - ReactiveAllocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 +let create () = Allocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 -let destroy = ReactiveAllocator.Block2.destroy +let destroy = Allocator.Block2.destroy let clear t = set_head t 0; @@ -35,16 +34,13 @@ 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 = - ReactiveAllocator.Block2.create ~capacity:new_cap ~x0:0 ~y0:old_len - 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 - ReactiveAllocator.Block2.set fresh i (ReactiveAllocator.Block2.get t src) + Allocator.Block2.set fresh i (Allocator.Block2.get t src) done; - ReactiveAllocator.Block2.blit ~src:fresh ~src_pos:0 ~dst:t ~dst_pos:0 - ~len:new_cap; - ReactiveAllocator.Block2.destroy fresh + Allocator.Block2.blit ~src:fresh ~src_pos:0 ~dst:t ~dst_pos:0 ~len:new_cap; + Allocator.Block2.destroy fresh let maybe_grow_before_push t = if length t = slot_capacity t then resize t (2 * slot_capacity t) @@ -52,12 +48,12 @@ let maybe_grow_before_push t = let push t x = maybe_grow_before_push t; let tail_i = tail t in - ReactiveAllocator.Block2.set t (slot_index t tail_i) x; + 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 "ReactiveFifo.pop: empty"; let head_i = head t in - let x = ReactiveAllocator.Block2.get t (slot_index t head_i) 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/ReactiveFifo.mli b/analysis/reactive/src/ReactiveFifo.mli index 06eb2c78549..7059123a429 100644 --- a/analysis/reactive/src/ReactiveFifo.mli +++ b/analysis/reactive/src/ReactiveFifo.mli @@ -12,13 +12,13 @@ val destroy : 'a t -> unit val clear : 'a t -> unit (** Remove all elements while keeping the current storage. *) -val push : 'a t -> 'a ReactiveAllocator.offheap -> unit +val push : 'a t -> 'a Allocator.offheap -> 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 ReactiveAllocator.offheap +val pop : 'a t -> 'a Allocator.offheap (** Remove and return the next element. @raise Invalid_argument if the queue is empty. *) diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index 5477c097aa2..f1c9594b208 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -23,8 +23,8 @@ type ('raw, 'v) internal = { type ('raw, 'v) t = { internal: ('raw, 'v) internal; collection: (string, 'v) Reactive.t; - emit: (string, 'v ReactiveMaybe.t) ReactiveWave.t -> unit; - scratch_wave: (string, 'v ReactiveMaybe.t) ReactiveWave.t; + emit: (string, 'v Maybe.t) ReactiveWave.t -> unit; + scratch_wave: (string, 'v Maybe.t) ReactiveWave.t; } (** A file collection is just a Reactive.t with some extra operations *) @@ -42,8 +42,8 @@ let to_collection t : (string, 'v) Reactive.t = t.collection let emit_set t path value = ReactiveWave.clear t.scratch_wave; ReactiveWave.push t.scratch_wave - (ReactiveAllocator.unsafe_to_offheap path) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some value)); + (Allocator.unsafe_to_offheap path) + (Allocator.unsafe_to_offheap (Maybe.some value)); t.emit t.scratch_wave (** Process a file if changed. Emits delta to subscribers. *) @@ -78,8 +78,8 @@ let process_files_batch t paths = let value = t.internal.process path raw in Hashtbl.replace t.internal.cache path (new_id, value); ReactiveWave.push t.scratch_wave - (ReactiveAllocator.unsafe_to_offheap path) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some value)); + (Allocator.unsafe_to_offheap path) + (Allocator.unsafe_to_offheap (Maybe.some value)); incr count) paths; if !count > 0 then t.emit t.scratch_wave; @@ -90,8 +90,8 @@ let remove t path = Hashtbl.remove t.internal.cache path; ReactiveWave.clear t.scratch_wave; ReactiveWave.push t.scratch_wave - (ReactiveAllocator.unsafe_to_offheap path) - ReactiveMaybe.none_offheap; + (Allocator.unsafe_to_offheap path) + Maybe.none_offheap; t.emit t.scratch_wave (** Remove multiple files as a batch *) @@ -103,8 +103,8 @@ let remove_batch t paths = if Hashtbl.mem t.internal.cache path then ( Hashtbl.remove t.internal.cache path; ReactiveWave.push t.scratch_wave - (ReactiveAllocator.unsafe_to_offheap path) - ReactiveMaybe.none_offheap; + (Allocator.unsafe_to_offheap path) + Maybe.none_offheap; incr count)) paths; if !count > 0 then t.emit t.scratch_wave; diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 9b30a25bedf..302dabe80c3 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -20,7 +20,7 @@ type 'k t = { edge_map: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; roots: 'k ReactiveSet.t; - output_wave: ('k, unit ReactiveMaybe.t) ReactiveWave.t; + output_wave: ('k, unit Maybe.t) ReactiveWave.t; (* Scratch tables — allocated once, cleared per apply_list call *) deleted_nodes: 'k ReactiveSet.t; rederive_pending: 'k ReactiveSet.t; @@ -53,7 +53,7 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs -let[@inline] off_key k = ReactiveAllocator.unsafe_to_offheap k +let[@inline] off_key k = Allocator.unsafe_to_offheap k let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) (* Full-reachability BFS into [visited]. Returns (node_work, edge_work). @@ -76,16 +76,14 @@ let compute_reachable ~visited t = let edge_work = ref 0 in ReactiveSet.iter_with (fun (visited, frontier) k -> - bfs_seed_root visited frontier t - (ReactiveAllocator.unsafe_from_offheap k) - ()) + bfs_seed_root visited frontier t (Allocator.unsafe_from_offheap k) ()) (visited, frontier) t.roots; while not (ReactiveFifo.is_empty frontier) do let k = ReactiveFifo.pop frontier in incr node_work; let r = ReactiveMap.find_maybe t.edge_map k in - if ReactiveMaybe.is_some r then ( - let succs = ReactiveMaybe.unsafe_get r in + if Maybe.is_some r then ( + let succs = Maybe.unsafe_get r in edge_work := !edge_work + ReactiveOffheapList.length succs; ReactiveOffheapList.iter_with (bfs_visit_succ visited) frontier succs) done; @@ -235,8 +233,7 @@ module Invariants = struct let copy_set_to_hashtbl (s : 'k ReactiveSet.t) = let out = Hashtbl.create (ReactiveSet.cardinal s) in ReactiveSet.iter_with - (fun out k -> - Hashtbl.replace out (ReactiveAllocator.unsafe_from_offheap k) ()) + (fun out k -> Hashtbl.replace out (Allocator.unsafe_from_offheap k) ()) out s; out @@ -255,8 +252,7 @@ module Invariants = struct let items = ref [] in while not (ReactiveFifo.is_empty edge_change_queue) do let src = - ReactiveAllocator.unsafe_from_offheap - (ReactiveFifo.pop edge_change_queue) + Allocator.unsafe_from_offheap (ReactiveFifo.pop edge_change_queue) in items := src :: !items; enqueue q_copy src @@ -271,14 +267,14 @@ module Invariants = struct ReactiveMap.find_maybe old_successors_for_changed (off_key src) in let old_succs = - if ReactiveMaybe.is_some r_old then ReactiveMaybe.unsafe_get r_old + if Maybe.is_some r_old then Maybe.unsafe_get r_old else ReactiveOffheapList.empty () in let r_new = ReactiveMap.find_maybe new_successors_for_changed (off_key src) in let new_succs = - if ReactiveMaybe.is_some r_new then ReactiveMaybe.unsafe_get r_new + if Maybe.is_some r_new then Maybe.unsafe_get r_new else ReactiveOffheapList.empty () in let expected_has_new = @@ -295,7 +291,7 @@ module Invariants = struct if enabled then ReactiveSet.iter_with (fun () k -> - let k = ReactiveAllocator.unsafe_from_offheap k in + let k = Allocator.unsafe_from_offheap k in assert_ (ReactiveSet.mem current (off_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ @@ -314,7 +310,7 @@ module Invariants = struct if enabled then ReactiveSet.iter_with (fun () k -> - let k = ReactiveAllocator.unsafe_from_offheap k in + let k = Allocator.unsafe_from_offheap k in if not (ReactiveSet.mem current (off_key k)) then assert_ (not (supported k)) @@ -327,7 +323,7 @@ module Invariants = struct let expected = Hashtbl.copy pre_current in ReactiveSet.iter_with (fun expected k -> - Hashtbl.remove expected (ReactiveAllocator.unsafe_from_offheap k)) + Hashtbl.remove expected (Allocator.unsafe_from_offheap k)) expected deleted_nodes; let current_ht = copy_set_to_hashtbl current in assert_ @@ -340,14 +336,14 @@ module Invariants = struct let expected = Hashtbl.create (ReactiveSet.cardinal deleted_nodes) in ReactiveSet.iter_with (fun expected k -> - let k = ReactiveAllocator.unsafe_from_offheap k in + let k = Allocator.unsafe_from_offheap k in if not (ReactiveSet.mem current (off_key k)) then Hashtbl.replace expected k ()) expected deleted_nodes; let actual = Hashtbl.create (List.length output_entries) in List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then Hashtbl.replace actual k ()) + if not (Maybe.is_some mv) then Hashtbl.replace actual k ()) output_entries; assert_ (set_equal expected actual) @@ -367,7 +363,7 @@ module Invariants = struct let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in ReactiveSet.iter_with (fun expected_adds k -> - let k = ReactiveAllocator.unsafe_from_offheap k in + let k = Allocator.unsafe_from_offheap k in if not (Hashtbl.mem pre_current k) then Hashtbl.replace expected_adds k ()) expected_adds t.current; @@ -381,7 +377,7 @@ module Invariants = struct let actual_removes = Hashtbl.create (List.length output_entries) in List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then Hashtbl.replace actual_adds k () + if Maybe.is_some mv then Hashtbl.replace actual_adds k () else Hashtbl.replace actual_removes k ()) output_entries; @@ -460,20 +456,19 @@ let destroy t = ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -type 'k root_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t -type 'k edge_wave = ('k, 'k list ReactiveMaybe.t) ReactiveWave.t -type 'k output_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t +type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t +type 'k edge_wave = ('k, 'k list Maybe.t) ReactiveWave.t +type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t let iter_current t f = ReactiveSet.iter_with - (fun f k -> f (ReactiveAllocator.unsafe_from_offheap k) ()) + (fun f k -> f (Allocator.unsafe_from_offheap k) ()) f t.current let get_current t k = - if ReactiveSet.mem t.current (off_key k) then ReactiveMaybe.some () - else ReactiveMaybe.none + if ReactiveSet.mem t.current (off_key k) then Maybe.some () else Maybe.none let current_length t = ReactiveSet.cardinal t.current @@ -488,9 +483,8 @@ let has_live_pred_key t pred = ReactiveSet.mem t.current (off_key pred) let has_live_predecessor t k = let r = ReactivePoolMapSet.find_maybe t.pred_map k in - if ReactiveMaybe.is_some r then - ReactiveHash.Set.exists_with has_live_pred_key t - (ReactiveMaybe.unsafe_get r) + if Maybe.is_some r then + ReactiveHash.Set.exists_with has_live_pred_key t (Maybe.unsafe_get r) else false let add_pred_for_src (t, src) target = add_pred t ~target ~pred:src @@ -499,8 +493,7 @@ let remove_pred_for_src (t, src) target = remove_pred t ~target ~pred:src let apply_edge_update t ~src ~new_successors = let r = ReactiveMap.find_maybe t.edge_map (off_key src) in let old_successors = - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r - else ReactiveOffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else ReactiveOffheapList.empty () in if ReactiveOffheapList.is_empty old_successors @@ -543,7 +536,7 @@ let initialize t ~roots ~edges = ReactiveWave.iter roots (fun k _ -> ReactiveSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> apply_edge_update t - ~src:(ReactiveAllocator.unsafe_from_offheap k) + ~src:(Allocator.unsafe_from_offheap k) ~new_successors:(ReactiveOffheapList.unsafe_of_offheap_list successors)); recompute_current t @@ -552,10 +545,10 @@ let is_supported t k = let old_successors t k = let r = ReactiveMap.find_maybe t.old_successors_for_changed (off_key k) in - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r + if Maybe.is_some r then Maybe.unsafe_get r else let r2 = ReactiveMap.find_maybe t.edge_map (off_key k) in - if ReactiveMaybe.is_some r2 then ReactiveMaybe.unsafe_get r2 + if Maybe.is_some r2 then Maybe.unsafe_get r2 else ReactiveOffheapList.empty () let mark_deleted t k = @@ -579,8 +572,8 @@ let add_live t k = ReactiveSet.add t.current (off_key k); if not (ReactiveSet.mem t.deleted_nodes (off_key k)) then ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveMaybe.maybe_unit_to_offheap (ReactiveMaybe.some ())); + (Allocator.unsafe_to_offheap k) + (Maybe.maybe_unit_to_offheap (Maybe.some ())); enqueue_expand t k) let enqueue_rederive_if_needed t k = @@ -595,8 +588,7 @@ let enqueue_rederive_if_needed t k = let scan_root_entry t k mv = let had_root = ReactiveSet.mem t.roots (off_key k) in - if ReactiveMaybe.is_some mv then ( - if not had_root then enqueue t.added_roots_queue k) + 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 set_add_k set k = ReactiveSet.add set (off_key k) @@ -614,12 +606,11 @@ let exists_not_in_set set xs = ReactiveOffheapList.exists_with not_in_set set xs let scan_edge_entry t src mv = let r = ReactiveMap.find_maybe t.edge_map (off_key src) in let old_succs = - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r - else ReactiveOffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else ReactiveOffheapList.empty () in let new_succs = - if ReactiveMaybe.is_some mv then - ReactiveOffheapList.unsafe_of_list (ReactiveMaybe.unsafe_get mv) + if Maybe.is_some mv then + ReactiveOffheapList.unsafe_of_list (Maybe.unsafe_get mv) else ReactiveOffheapList.empty () in ReactiveMap.replace t.old_successors_for_changed (off_key src) old_succs; @@ -645,14 +636,14 @@ let scan_edge_entry t src mv = ReactiveSet.add t.edge_has_new (off_key src) let apply_root_mutation t k mv = - if ReactiveMaybe.is_some mv then ReactiveSet.add t.roots (off_key k) + if Maybe.is_some mv then ReactiveSet.add t.roots (off_key k) else ReactiveSet.remove t.roots (off_key k) let emit_removal t k () = if not (ReactiveSet.mem t.current (off_key k)) then ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k) - ReactiveMaybe.none_offheap + (Allocator.unsafe_to_offheap k) + Maybe.none_offheap let rebuild_edge_change_queue t src _succs = ReactiveFifo.push t.edge_change_queue src @@ -682,8 +673,8 @@ let apply_list t ~roots ~edges = ReactiveWave.iter_with roots (fun t k mv -> scan_root_entry t - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap mv)) + (Allocator.unsafe_from_offheap k) + (Allocator.unsafe_from_offheap mv)) t; (* Phase 1b: scan edge entries — seed delete queue for removed targets, @@ -691,8 +682,8 @@ let apply_list t ~roots ~edges = ReactiveWave.iter_with edges (fun t src mv -> scan_edge_entry t - (ReactiveAllocator.unsafe_from_offheap src) - (ReactiveAllocator.unsafe_from_offheap mv)) + (Allocator.unsafe_from_offheap src) + (Allocator.unsafe_from_offheap mv)) t; Invariants.assert_edge_has_new_consistent @@ -703,9 +694,7 @@ let apply_list t ~roots ~edges = (* Phase 2: delete BFS *) while not (ReactiveFifo.is_empty t.delete_queue) do - let k = - ReactiveAllocator.unsafe_from_offheap (ReactiveFifo.pop t.delete_queue) - in + let k = Allocator.unsafe_from_offheap (ReactiveFifo.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; @@ -721,8 +710,8 @@ let apply_list t ~roots ~edges = ReactiveWave.iter_with roots (fun t k mv -> apply_root_mutation t - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap mv)) + (Allocator.unsafe_from_offheap k) + (Allocator.unsafe_from_offheap mv)) t; (* Apply edge updates by draining edge_change_queue. *) @@ -730,11 +719,11 @@ let apply_list t ~roots ~edges = let src = ReactiveFifo.pop t.edge_change_queue in let r = ReactiveMap.find_maybe t.new_successors_for_changed src in let new_succs = - if ReactiveMaybe.is_some r then ReactiveMaybe.unsafe_get r + if Maybe.is_some r then Maybe.unsafe_get r else ReactiveOffheapList.empty () in apply_edge_update t - ~src:(ReactiveAllocator.unsafe_from_offheap src) + ~src:(Allocator.unsafe_from_offheap src) ~new_successors:new_succs done; (* Rebuild edge_change_queue from new_successors_for_changed keys for @@ -754,7 +743,7 @@ let apply_list t ~roots ~edges = ReactiveSet.iter_with (fun t k -> - enqueue_rederive_if_needed_kv t (ReactiveAllocator.unsafe_from_offheap k)) + enqueue_rederive_if_needed_kv t (Allocator.unsafe_from_offheap k)) t t.deleted_nodes; while not (ReactiveFifo.is_empty t.rederive_queue) do @@ -764,13 +753,13 @@ let apply_list t ~roots ~edges = if ReactiveSet.mem t.deleted_nodes k && (not (ReactiveSet.mem t.current k)) - && is_supported t (ReactiveAllocator.unsafe_from_offheap k) + && is_supported t (Allocator.unsafe_from_offheap k) then ( ReactiveSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; let r = ReactiveMap.find_maybe t.edge_map k in - if ReactiveMaybe.is_some r then ( - let succs = ReactiveMaybe.unsafe_get r in + if Maybe.is_some r then ( + let succs = Maybe.unsafe_get r in if Metrics.enabled then m.rederive_edges_scanned <- m.rederive_edges_scanned + ReactiveOffheapList.length succs; @@ -787,38 +776,37 @@ let apply_list t ~roots ~edges = (* Seed expansion from added roots *) while not (ReactiveFifo.is_empty t.added_roots_queue) do add_live t - (ReactiveAllocator.unsafe_from_offheap - (ReactiveFifo.pop t.added_roots_queue)) + (Allocator.unsafe_from_offheap (ReactiveFifo.pop t.added_roots_queue)) done; (* Seed expansion from edge changes with new edges *) while not (ReactiveFifo.is_empty t.edge_change_queue) do let src = ReactiveFifo.pop t.edge_change_queue in if ReactiveSet.mem t.current src && ReactiveSet.mem t.edge_has_new src then - enqueue_expand t (ReactiveAllocator.unsafe_from_offheap src) + enqueue_expand t (Allocator.unsafe_from_offheap src) done; while not (ReactiveFifo.is_empty t.expansion_queue) do let k = ReactiveFifo.pop t.expansion_queue in if Metrics.enabled then m.expansion_queue_pops <- m.expansion_queue_pops + 1; let r = ReactiveMap.find_maybe t.edge_map k in - if ReactiveMaybe.is_some r then ( - let succs = ReactiveMaybe.unsafe_get r in + if Maybe.is_some r then ( + let succs = Maybe.unsafe_get r in if Metrics.enabled then m.expansion_edges_scanned <- m.expansion_edges_scanned + ReactiveOffheapList.length succs; ReactiveOffheapList.iter_with add_live t succs) done; ReactiveSet.iter_with - (fun t k -> emit_removal t (ReactiveAllocator.unsafe_from_offheap k) ()) + (fun t k -> emit_removal t (Allocator.unsafe_from_offheap k) ()) t t.deleted_nodes; let output_entries_list = if Invariants.enabled then ( let entries = ref [] in ReactiveWave.iter t.output_wave (fun k v_opt -> entries := - ( ReactiveAllocator.unsafe_from_offheap k, - ReactiveAllocator.unsafe_from_offheap v_opt ) + ( Allocator.unsafe_from_offheap k, + Allocator.unsafe_from_offheap v_opt ) :: !entries); !entries) else [] diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index a5a9bcd31c5..22fb61e9092 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -3,9 +3,9 @@ type 'k t This implementation uses fixed-capacity arrays allocated in [create]. *) -type 'k root_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t -type 'k edge_wave = ('k, 'k list ReactiveMaybe.t) ReactiveWave.t -type 'k output_wave = ('k, unit ReactiveMaybe.t) ReactiveWave.t +type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t +type 'k edge_wave = ('k, 'k list Maybe.t) ReactiveWave.t +type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t @@ -22,7 +22,7 @@ val output_wave : 'k t -> 'k output_wave (** The owned output wave populated by [apply_wave]. *) val iter_current : 'k t -> ('k -> unit -> unit) -> unit -val get_current : 'k t -> 'k -> unit ReactiveMaybe.t +val get_current : 'k t -> 'k -> unit Maybe.t val current_length : 'k t -> int val initialize : diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 48b2dfce993..94e335134e7 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -8,10 +8,10 @@ type ('k1, 'v1, 'k2, 'v2) t = { contributions: ('k2, 'k1, 'v2) ReactivePoolMapMap.t; target: ('k2, 'v2) ReactiveMap.t; (* Scratch — allocated once, cleared per process() *) - scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveMap.t; + scratch: ('k1, 'v1 Maybe.t) ReactiveMap.t; affected: 'k2 ReactiveSet.t; (* Pre-allocated output buffer *) - output_wave: ('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t; + output_wave: ('k2, 'v2 Maybe.t) ReactiveWave.t; (* Emit callback state — allocated once, reused per entry *) mutable current_k1: 'k1; emit_fn: 'k2 -> 'v2 -> unit; @@ -35,15 +35,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k2) + ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k2) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k2) - (ReactiveAllocator.unsafe_to_offheap v2) + (Allocator.unsafe_to_offheap k2) + (Allocator.unsafe_to_offheap v2) let create ~f ~merge = let rec t = @@ -87,7 +87,7 @@ let push t k v_opt = ReactiveMap.replace t.scratch k v_opt let remove_one_contribution (t : (_, _, _, _) t) k2 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 t.current_k1; - ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k2) + ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k2) let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; @@ -101,39 +101,39 @@ let merge_one_contribution (t : (_, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _) t) k2 = - let k2 = ReactiveAllocator.unsafe_from_offheap k2 in + let k2 = Allocator.unsafe_from_offheap k2 in if ReactivePoolMapMap.inner_cardinal t.contributions k2 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k2) - (ReactiveAllocator.unsafe_to_offheap t.merge_acc); + (Allocator.unsafe_to_offheap k2) + (Allocator.unsafe_to_offheap t.merge_acc); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k2) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some t.merge_acc))) + (Allocator.unsafe_to_offheap k2) + (Allocator.unsafe_to_offheap (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (ReactiveAllocator.unsafe_to_offheap k2); + ReactiveMap.remove t.target (Allocator.unsafe_to_offheap k2); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k2) - ReactiveMaybe.none_offheap) + (Allocator.unsafe_to_offheap k2) + Maybe.none_offheap) (* Single-pass process + count for scratch *) let process_scratch_entry (t : (_, _, _, _) t) k1 mv = - let k1 = ReactiveAllocator.unsafe_from_offheap k1 in - let mv = ReactiveAllocator.unsafe_from_offheap mv in + let k1 = Allocator.unsafe_from_offheap k1 in + let mv = Allocator.unsafe_from_offheap mv in t.result.entries_received <- t.result.entries_received + 1; remove_source t k1; - if ReactiveMaybe.is_some mv then ( + if Maybe.is_some mv then ( t.result.adds_received <- t.result.adds_received + 1; - let v1 = ReactiveMaybe.unsafe_get mv in + let v1 = Maybe.unsafe_get mv in t.current_k1 <- k1; t.f k1 v1 t.emit_fn) else t.result.removes_received <- t.result.removes_received + 1 let count_output_entry (r : process_result) _k mv = - let mv = ReactiveAllocator.unsafe_from_offheap mv in - if ReactiveMaybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 + let mv = Allocator.unsafe_from_offheap 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) = @@ -165,16 +165,14 @@ let init_entry (t : (_, _, _, _) t) k1 v1 = let iter_target f t = ReactiveMap.iter (fun k v -> - f - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v)) + f (Allocator.unsafe_from_offheap k) (Allocator.unsafe_from_offheap v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (ReactiveAllocator.unsafe_to_offheap k) - |> ReactiveMaybe.to_option + ReactiveMap.find_maybe t.target (Allocator.unsafe_to_offheap k) + |> Maybe.to_option |> function - | Some v -> ReactiveMaybe.some (ReactiveAllocator.unsafe_from_offheap v) - | None -> ReactiveMaybe.none + | Some v -> Maybe.some (Allocator.unsafe_from_offheap v) + | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 69bed51e8ce..6e21c84a3d7 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -22,14 +22,13 @@ val destroy : ('k1, 'v1, 'k2, 'v2) t -> unit (** Release flatMap-owned off-heap storage. The state must not be used afterwards. *) -val output_wave : - ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 ReactiveMaybe.t) ReactiveWave.t +val output_wave : ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) val push : ('k1, 'v1, 'k2, 'v2) t -> - 'k1 ReactiveAllocator.offheap -> - 'v1 ReactiveMaybe.t ReactiveAllocator.offheap -> + 'k1 Allocator.offheap -> + 'v1 Maybe.t Allocator.offheap -> unit (** Push an entry into the scratch table. *) @@ -42,5 +41,5 @@ val init_entry : ('k1, 'v1, 'k2, 'v2) t -> 'k1 -> 'v1 -> unit (** Initialize from an existing source entry (during setup). *) val iter_target : ('k2 -> 'v2 -> unit) -> ('k1, 'v1, 'k2, 'v2) t -> unit -val find_target : ('k1, 'v1, 'k2, 'v2) t -> 'k2 -> 'v2 ReactiveMaybe.t +val find_target : ('k1, 'v1, 'k2, 'v2) t -> 'k2 -> 'v2 Maybe.t val target_length : ('k1, 'v1, 'k2, 'v2) t -> int diff --git a/analysis/reactive/src/ReactiveHash.ml b/analysis/reactive/src/ReactiveHash.ml index 0aceb2ca29d..dbb746e43fe 100644 --- a/analysis/reactive/src/ReactiveHash.ml +++ b/analysis/reactive/src/ReactiveHash.ml @@ -125,7 +125,7 @@ let[@inline] table_find t x = find_probe t x (start t x) (* ---- find_maybe (zero-allocation) ---- *) -let maybe_none_obj : Obj.t = Obj.repr ReactiveMaybe.none +let maybe_none_obj : Obj.t = Obj.repr Maybe.none let rec find_maybe_probe t x j = let c = Array.unsafe_get t.keys j in @@ -379,7 +379,7 @@ module Map = struct let find (type k v) (t : (k, v) t) (k : k) : v = (Obj.obj (table_find t (Obj.repr k)) : v) - let find_maybe (type k v) (t : (k, v) t) (k : k) : v ReactiveMaybe.t = + let find_maybe (type k v) (t : (k, v) t) (k : k) : v Maybe.t = Obj.obj (table_find_maybe t (Obj.repr k)) let mem (type k v) (t : (k, v) t) (k : k) = table_mem t (Obj.repr k) diff --git a/analysis/reactive/src/ReactiveHash.mli b/analysis/reactive/src/ReactiveHash.mli index 03bc7ca83e6..a388be3c75f 100644 --- a/analysis/reactive/src/ReactiveHash.mli +++ b/analysis/reactive/src/ReactiveHash.mli @@ -12,7 +12,7 @@ module Map : sig val replace : ('k, 'v) t -> 'k -> 'v -> unit val find_opt : ('k, 'v) t -> 'k -> 'v option val find : ('k, 'v) t -> 'k -> 'v - val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t + val find_maybe : ('k, 'v) t -> 'k -> 'v Maybe.t val mem : ('k, 'v) t -> 'k -> bool val remove : ('k, 'v) t -> 'k -> unit diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 9d9b862e3e5..ec6bc53bdf7 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -2,9 +2,9 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { key_of: 'k1 -> 'v1 -> 'k2; - f: 'k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit; + f: 'k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit; merge: 'v3 -> 'v3 -> 'v3; - right_get: 'k2 -> 'v2 ReactiveMaybe.t; + right_get: 'k2 -> 'v2 Maybe.t; (* Persistent state *) left_entries: ('k1, 'v1) ReactiveMap.t; provenance: ('k1, 'k3) ReactivePoolMapSet.t; @@ -13,11 +13,11 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { left_to_right_key: ('k1, 'k2) ReactiveMap.t; right_key_to_left_keys: ('k2, 'k1) ReactivePoolMapSet.t; (* Scratch — allocated once, cleared per process() *) - left_scratch: ('k1, 'v1 ReactiveMaybe.t) ReactiveMap.t; - right_scratch: ('k2, 'v2 ReactiveMaybe.t) ReactiveMap.t; + left_scratch: ('k1, 'v1 Maybe.t) ReactiveMap.t; + right_scratch: ('k2, 'v2 Maybe.t) ReactiveMap.t; affected: 'k3 ReactiveSet.t; (* Pre-allocated output buffer *) - output_wave: ('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t; + output_wave: ('k3, 'v3 Maybe.t) ReactiveWave.t; (* Emit callback state — allocated once, reused per entry *) mutable current_k1: 'k1; emit_fn: 'k3 -> 'v3 -> unit; @@ -41,15 +41,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k3) + ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k3) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k3) - (ReactiveAllocator.unsafe_to_offheap v3) + (Allocator.unsafe_to_offheap k3) + (Allocator.unsafe_to_offheap v3) let create ~key_of ~f ~merge ~right_get = let rec t = @@ -104,7 +104,7 @@ let push_right t k v_opt = ReactiveMap.replace t.right_scratch k v_opt let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 t.current_k1; - ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k3) + ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k3) let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; @@ -112,15 +112,11 @@ let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = let mb = - ReactiveMap.find_maybe t.left_to_right_key - (ReactiveAllocator.unsafe_to_offheap k1) + ReactiveMap.find_maybe t.left_to_right_key (Allocator.unsafe_to_offheap k1) in - if ReactiveMaybe.is_some mb then ( - let old_k2 = - ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get mb) - in - ReactiveMap.remove t.left_to_right_key - (ReactiveAllocator.unsafe_to_offheap k1); + if Maybe.is_some mb then ( + let old_k2 = Allocator.unsafe_from_offheap (Maybe.unsafe_get mb) in + ReactiveMap.remove t.left_to_right_key (Allocator.unsafe_to_offheap k1); ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys old_k2 k1) @@ -129,15 +125,15 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = unlink_right_key t k1; let k2 = t.key_of k1 v1 in ReactiveMap.replace t.left_to_right_key - (ReactiveAllocator.unsafe_to_offheap k1) - (ReactiveAllocator.unsafe_to_offheap k2); + (Allocator.unsafe_to_offheap k1) + (Allocator.unsafe_to_offheap k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; t.f k1 v1 right_val t.emit_fn let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = - ReactiveMap.remove t.left_entries (ReactiveAllocator.unsafe_to_offheap k1); + ReactiveMap.remove t.left_entries (Allocator.unsafe_to_offheap k1); remove_left_contributions t k1; unlink_right_key t k1 @@ -149,34 +145,34 @@ let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _, _, _) t) k3 = - let k3 = ReactiveAllocator.unsafe_from_offheap k3 in + let k3 = Allocator.unsafe_from_offheap k3 in if ReactivePoolMapMap.inner_cardinal t.contributions k3 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k3) - (ReactiveAllocator.unsafe_to_offheap t.merge_acc); + (Allocator.unsafe_to_offheap k3) + (Allocator.unsafe_to_offheap t.merge_acc); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k3) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some t.merge_acc))) + (Allocator.unsafe_to_offheap k3) + (Allocator.unsafe_to_offheap (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (ReactiveAllocator.unsafe_to_offheap k3); + ReactiveMap.remove t.target (Allocator.unsafe_to_offheap k3); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k3) - ReactiveMaybe.none_offheap) + (Allocator.unsafe_to_offheap k3) + Maybe.none_offheap) (* Single-pass process + count for left scratch *) let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = - let k1 = ReactiveAllocator.unsafe_from_offheap k1 in - let mv = ReactiveAllocator.unsafe_from_offheap mv in + let k1 = Allocator.unsafe_from_offheap k1 in + let mv = Allocator.unsafe_from_offheap mv in t.result.entries_received <- t.result.entries_received + 1; - if ReactiveMaybe.is_some mv then ( + if Maybe.is_some mv then ( t.result.adds_received <- t.result.adds_received + 1; - let v1 = ReactiveMaybe.unsafe_get mv in + let v1 = Maybe.unsafe_get mv in ReactiveMap.replace t.left_entries - (ReactiveAllocator.unsafe_to_offheap k1) - (ReactiveAllocator.unsafe_to_offheap v1); + (Allocator.unsafe_to_offheap k1) + (Allocator.unsafe_to_offheap v1); process_left_entry t k1 v1) else ( t.result.removes_received <- t.result.removes_received + 1; @@ -185,29 +181,26 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = let mb = - ReactiveMap.find_maybe t.left_entries - (ReactiveAllocator.unsafe_to_offheap k1) + ReactiveMap.find_maybe t.left_entries (Allocator.unsafe_to_offheap k1) in - if ReactiveMaybe.is_some mb then + if Maybe.is_some mb then process_left_entry t k1 - (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get mb)) + (Allocator.unsafe_from_offheap (Maybe.unsafe_get mb)) (* Single-pass process + count for right scratch *) let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = - let k2 = ReactiveAllocator.unsafe_from_offheap k2 in - let _mv = ReactiveAllocator.unsafe_from_offheap _mv in + let k2 = Allocator.unsafe_from_offheap k2 in + let _mv = Allocator.unsafe_from_offheap _mv in t.result.entries_received <- t.result.entries_received + 1; - if ReactiveMaybe.is_some _mv then - t.result.adds_received <- t.result.adds_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; let mb = ReactivePoolMapSet.find_maybe t.right_key_to_left_keys k2 in - if ReactiveMaybe.is_some mb then - ReactiveHash.Set.iter_with reprocess_left_entry t - (ReactiveMaybe.unsafe_get mb) + if Maybe.is_some mb then + ReactiveHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = - let mv = ReactiveAllocator.unsafe_from_offheap mv in - if ReactiveMaybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 + let mv = Allocator.unsafe_from_offheap 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) = @@ -237,12 +230,12 @@ let process (t : (_, _, _, _, _, _) t) = let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = ReactiveMap.replace t.left_entries - (ReactiveAllocator.unsafe_to_offheap k1) - (ReactiveAllocator.unsafe_to_offheap v1); + (Allocator.unsafe_to_offheap k1) + (Allocator.unsafe_to_offheap v1); let k2 = t.key_of k1 v1 in ReactiveMap.replace t.left_to_right_key - (ReactiveAllocator.unsafe_to_offheap k1) - (ReactiveAllocator.unsafe_to_offheap k2); + (Allocator.unsafe_to_offheap k1) + (Allocator.unsafe_to_offheap k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; @@ -251,16 +244,14 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = let iter_target f t = ReactiveMap.iter (fun k v -> - f - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v)) + f (Allocator.unsafe_from_offheap k) (Allocator.unsafe_from_offheap v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (ReactiveAllocator.unsafe_to_offheap k) - |> ReactiveMaybe.to_option + ReactiveMap.find_maybe t.target (Allocator.unsafe_to_offheap k) + |> Maybe.to_option |> function - | Some v -> ReactiveMaybe.some (ReactiveAllocator.unsafe_from_offheap v) - | None -> ReactiveMaybe.none + | Some v -> Maybe.some (Allocator.unsafe_from_offheap v) + | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index bc61b6b144d..ff7964f46e9 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -15,9 +15,9 @@ type process_result = { val create : key_of:('k1 -> 'v1 -> 'k2) -> - f:('k1 -> 'v1 -> 'v2 ReactiveMaybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> + f:('k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> merge:('v3 -> 'v3 -> 'v3) -> - right_get:('k2 -> 'v2 ReactiveMaybe.t) -> + right_get:('k2 -> 'v2 Maybe.t) -> ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t val destroy : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit @@ -25,20 +25,20 @@ val destroy : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit afterwards. *) val output_wave : - ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> ('k3, 'v3 ReactiveMaybe.t) ReactiveWave.t + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> ('k3, 'v3 Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) val push_left : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> - 'k1 ReactiveAllocator.offheap -> - 'v1 ReactiveMaybe.t ReactiveAllocator.offheap -> + 'k1 Allocator.offheap -> + 'v1 Maybe.t Allocator.offheap -> unit (** Push an entry into the left scratch table. *) val push_right : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> - 'k2 ReactiveAllocator.offheap -> - 'v2 ReactiveMaybe.t ReactiveAllocator.offheap -> + 'k2 Allocator.offheap -> + 'v2 Maybe.t Allocator.offheap -> unit (** Push an entry into the right scratch table. *) @@ -52,5 +52,5 @@ val init_entry : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k1 -> 'v1 -> unit val iter_target : ('k3 -> 'v3 -> unit) -> ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit -val find_target : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k3 -> 'v3 ReactiveMaybe.t +val find_target : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k3 -> 'v3 Maybe.t val target_length : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> int diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/ReactiveMap.ml index 633892bdd82..a85e58fb8da 100644 --- a/analysis/reactive/src/ReactiveMap.ml +++ b/analysis/reactive/src/ReactiveMap.ml @@ -1,6 +1,6 @@ type ('k, 'v) t = { - keys: ('k, int, int) ReactiveAllocator.Block2.t; - vals: ReactiveAllocator.Block.t; + keys: ('k, int, int) Allocator.Block2.t; + vals: Allocator.Block.t; } let initial_capacity = 8 @@ -9,41 +9,37 @@ 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 ReactiveAllocator.offheap = - Obj.magic empty_sentinel -let[@inline] tomb_slot () : 'a ReactiveAllocator.offheap = - Obj.magic tomb_sentinel +let[@inline] empty_slot () : 'a Allocator.offheap = Obj.magic empty_sentinel +let[@inline] tomb_slot () : 'a Allocator.offheap = Obj.magic tomb_sentinel -let key_capacity t = ReactiveAllocator.Block2.capacity t.keys -let population t = ReactiveAllocator.Block2.get0 t.keys -let set_population t n = ReactiveAllocator.Block2.set0 t.keys n -let occupation t = ReactiveAllocator.Block2.get1 t.keys -let set_occupation t n = ReactiveAllocator.Block2.set1 t.keys n +let key_capacity t = Allocator.Block2.capacity t.keys +let population t = Allocator.Block2.get0 t.keys +let set_population t n = Allocator.Block2.set0 t.keys n +let occupation t = Allocator.Block2.get1 t.keys +let set_occupation t n = Allocator.Block2.set1 t.keys n let[@inline] mask t = key_capacity t - 1 let[@inline] start t x = - Hashtbl.hash (ReactiveAllocator.unsafe_from_offheap x) land mask t + Hashtbl.hash (Allocator.unsafe_from_offheap 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 key_capacity t - 1 do - ReactiveAllocator.Block2.set t.keys i (empty_slot ()) + Allocator.Block2.set t.keys i (empty_slot ()) done let create () = - let keys = - ReactiveAllocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 - in - let vals = ReactiveAllocator.Block.create ~capacity:initial_capacity in + let keys = Allocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 in + let vals = Allocator.Block.create ~capacity:initial_capacity in let t = {keys; vals} in clear_keys t; t let destroy t = - ReactiveAllocator.Block2.destroy t.keys; - ReactiveAllocator.Block.destroy t.vals + Allocator.Block2.destroy t.keys; + Allocator.Block.destroy t.vals let clear t = set_population t 0; @@ -51,38 +47,36 @@ let clear t = clear_keys t let insert_absent t k v = - let empty : 'k ReactiveAllocator.offheap = empty_slot () in + let empty : 'k Allocator.offheap = empty_slot () in let j = ref (start t k) in - while ReactiveAllocator.Block2.get t.keys !j != empty do + while Allocator.Block2.get t.keys !j != empty do j := next t !j done; - ReactiveAllocator.Block2.set t.keys !j k; - ReactiveAllocator.Block.set t.vals !j v + Allocator.Block2.set t.keys !j k; + Allocator.Block.set t.vals !j v let resize t new_cap = let old_cap = key_capacity t in - let old_keys = - ReactiveAllocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:0 - in - let old_vals = ReactiveAllocator.Block.create ~capacity:old_cap in - ReactiveAllocator.Block2.blit ~src:t.keys ~src_pos:0 ~dst:old_keys ~dst_pos:0 + let old_keys = Allocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:0 in + let old_vals = Allocator.Block.create ~capacity:old_cap in + Allocator.Block2.blit ~src:t.keys ~src_pos:0 ~dst:old_keys ~dst_pos:0 ~len:old_cap; - ReactiveAllocator.Block.blit ~src:t.vals ~src_pos:0 ~dst:old_vals ~dst_pos:0 + Allocator.Block.blit ~src:t.vals ~src_pos:0 ~dst:old_vals ~dst_pos:0 ~len:old_cap; - ReactiveAllocator.Block2.resize t.keys ~capacity:new_cap; - ReactiveAllocator.Block.resize t.vals ~capacity:new_cap; + Allocator.Block2.resize t.keys ~capacity:new_cap; + Allocator.Block.resize t.vals ~capacity:new_cap; set_population t 0; set_occupation t 0; clear_keys t; for i = 0 to old_cap - 1 do - let k = ReactiveAllocator.Block2.get old_keys i in + let k = Allocator.Block2.get old_keys i in if k != empty_slot () && k != tomb_slot () then ( - insert_absent t k (ReactiveAllocator.Block.get old_vals i); + insert_absent t k (Allocator.Block.get old_vals i); set_population t (population t + 1); set_occupation t (occupation t + 1)) done; - ReactiveAllocator.Block2.destroy old_keys; - ReactiveAllocator.Block.destroy old_vals + Allocator.Block2.destroy old_keys; + Allocator.Block.destroy old_vals let maybe_grow_before_insert t = let cap = key_capacity t in @@ -91,53 +85,53 @@ let maybe_grow_before_insert t = let replace t k v = maybe_grow_before_insert t; - let empty : 'k ReactiveAllocator.offheap = empty_slot () in - let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let empty : 'k Allocator.offheap = empty_slot () in + let tomb : 'k Allocator.offheap = 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 = ReactiveAllocator.Block2.get t.keys !j in + let current = Allocator.Block2.get t.keys !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); - ReactiveAllocator.Block2.set t.keys dst k; - ReactiveAllocator.Block.set t.vals dst v; + Allocator.Block2.set t.keys dst k; + Allocator.Block.set t.vals 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 ( - ReactiveAllocator.Block.set t.vals !j v; + Allocator.Block.set t.vals !j v; done_ := true) else j := next t !j done let remove t k = - let empty : 'k ReactiveAllocator.offheap = empty_slot () in - let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let empty : 'k Allocator.offheap = empty_slot () in + let tomb : 'k Allocator.offheap = tomb_slot () in let j = ref (start t k) in let done_ = ref false in while not !done_ do - let current = ReactiveAllocator.Block2.get t.keys !j in + let current = Allocator.Block2.get t.keys !j in if current == empty then done_ := true else if current == tomb then j := next t !j else if current = k then ( - ReactiveAllocator.Block2.set t.keys !j tomb; + Allocator.Block2.set t.keys !j tomb; set_population t (population t - 1); done_ := true) else j := next t !j done let mem t k = - let empty : 'k ReactiveAllocator.offheap = empty_slot () in - let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let empty : 'k Allocator.offheap = empty_slot () in + let tomb : 'k Allocator.offheap = 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 = ReactiveAllocator.Block2.get t.keys !j in + let current = Allocator.Block2.get t.keys !j in if current == empty then done_ := true else if current == tomb then j := next t !j else if current = k then ( @@ -148,30 +142,29 @@ let mem t k = !found let find_maybe t k = - let empty : 'k ReactiveAllocator.offheap = empty_slot () in - let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let empty : 'k Allocator.offheap = empty_slot () in + let tomb : 'k Allocator.offheap = tomb_slot () in let j = ref (start t k) in - let found = ref ReactiveMaybe.none in + let found = ref Maybe.none in let done_ = ref false in while not !done_ do - let current = ReactiveAllocator.Block2.get t.keys !j in + let current = Allocator.Block2.get t.keys !j in if current == empty then done_ := true else if current == tomb then j := next t !j else if current = k then ( - found := ReactiveMaybe.some (ReactiveAllocator.Block.get t.vals !j); + found := Maybe.some (Allocator.Block.get t.vals !j); done_ := true) else j := next t !j done; !found let iter_with f arg t = - let empty : 'k ReactiveAllocator.offheap = empty_slot () in - let tomb : 'k ReactiveAllocator.offheap = tomb_slot () in + let empty : 'k Allocator.offheap = empty_slot () in + let tomb : 'k Allocator.offheap = tomb_slot () in if population t > 0 then for i = 0 to key_capacity t - 1 do - let k = ReactiveAllocator.Block2.get t.keys i in - if k != empty && k != tomb then - f arg k (ReactiveAllocator.Block.get t.vals i) + let k = Allocator.Block2.get t.keys i in + if k != empty && k != tomb then f arg k (Allocator.Block.get t.vals i) done let iter f t = iter_with (fun f k v -> f k v) f t diff --git a/analysis/reactive/src/ReactiveMap.mli b/analysis/reactive/src/ReactiveMap.mli index a247170c9e1..b93a5e834a2 100644 --- a/analysis/reactive/src/ReactiveMap.mli +++ b/analysis/reactive/src/ReactiveMap.mli @@ -6,30 +6,22 @@ val create : unit -> ('k, 'v) t val destroy : ('k, 'v) t -> unit val clear : ('k, 'v) t -> unit -val replace : - ('k, 'v) t -> - 'k ReactiveAllocator.offheap -> - 'v ReactiveAllocator.offheap -> - unit +val replace : ('k, 'v) t -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit -val remove : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> unit +val remove : ('k, 'v) t -> 'k Allocator.offheap -> unit -val mem : ('k, 'v) t -> 'k ReactiveAllocator.offheap -> bool +val mem : ('k, 'v) t -> 'k Allocator.offheap -> bool val find_maybe : - ('k, 'v) t -> - 'k ReactiveAllocator.offheap -> - 'v ReactiveAllocator.offheap ReactiveMaybe.t + ('k, 'v) t -> 'k Allocator.offheap -> 'v Allocator.offheap Maybe.t val iter_with : - ('a -> 'k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> + ('a -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit) -> 'a -> ('k, 'v) t -> unit val iter : - ('k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> - ('k, 'v) t -> - unit + ('k Allocator.offheap -> 'v Allocator.offheap -> unit) -> ('k, 'v) t -> unit val cardinal : ('k, 'v) t -> int diff --git a/analysis/reactive/src/ReactiveOffheapList.ml b/analysis/reactive/src/ReactiveOffheapList.ml index 595b256a997..7d9b8c55553 100644 --- a/analysis/reactive/src/ReactiveOffheapList.ml +++ b/analysis/reactive/src/ReactiveOffheapList.ml @@ -1,11 +1,11 @@ type 'a inner = 'a list -type 'a t = 'a inner ReactiveAllocator.offheap +type 'a t = 'a inner Allocator.offheap -let unsafe_of_list = ReactiveAllocator.unsafe_to_offheap -let of_list = ReactiveAllocator.to_offheap -let list_of = ReactiveAllocator.unsafe_from_offheap +let unsafe_of_list = Allocator.unsafe_to_offheap +let of_list = Allocator.to_offheap +let list_of = Allocator.unsafe_from_offheap let unsafe_of_offheap_list xs = - unsafe_of_list (ReactiveAllocator.unsafe_from_offheap xs) + unsafe_of_list (Allocator.unsafe_from_offheap xs) let empty () : 'a t = unsafe_of_list [] diff --git a/analysis/reactive/src/ReactiveOffheapList.mli b/analysis/reactive/src/ReactiveOffheapList.mli index d13fa075f3d..5ad2426185a 100644 --- a/analysis/reactive/src/ReactiveOffheapList.mli +++ b/analysis/reactive/src/ReactiveOffheapList.mli @@ -4,7 +4,7 @@ boundary explicit when such a list is stored in an off-heap container. *) type 'a inner -type 'a t = 'a inner ReactiveAllocator.offheap +type 'a t = 'a inner Allocator.offheap val unsafe_of_list : 'a list -> 'a t (** Reinterpret a list as offheap-marked without checking. *) @@ -13,7 +13,7 @@ val of_list : 'a list -> 'a t (** Checked version of [unsafe_of_list]. Raises if the list is still in the minor heap. *) -val unsafe_of_offheap_list : 'a list ReactiveAllocator.offheap -> 'a t +val unsafe_of_offheap_list : 'a list Allocator.offheap -> 'a t (** Reinterpret an already offheap-marked list as an offheap-list value. *) val empty : unit -> 'a t diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml index bcb752e18db..7e4d5c4f20b 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.ml +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -47,7 +47,7 @@ let pool_pop t = let ensure_inner t ko = let m = ReactiveHash.Map.find_maybe t.outer ko in - if ReactiveMaybe.is_some m then ReactiveMaybe.unsafe_get m + if Maybe.is_some m then Maybe.unsafe_get m else let inner = pool_pop t in ReactiveHash.Map.replace t.outer ko inner; @@ -59,8 +59,8 @@ let replace t ko ki v = let remove_from_inner_and_recycle_if_empty t ko ki = let mb = ReactiveHash.Map.find_maybe t.outer ko in - if ReactiveMaybe.is_some mb then ( - let inner = ReactiveMaybe.unsafe_get mb in + if Maybe.is_some mb then ( + let inner = Maybe.unsafe_get mb in ReactiveHash.Map.remove inner ki; let after = ReactiveHash.Map.cardinal inner in if after = 0 then ( @@ -73,8 +73,8 @@ let remove_from_inner_and_recycle_if_empty t ko ki = let drain_outer t ko ctx f = let mb = ReactiveHash.Map.find_maybe t.outer ko in - if ReactiveMaybe.is_some mb then ( - let inner = ReactiveMaybe.unsafe_get mb in + if Maybe.is_some mb then ( + let inner = Maybe.unsafe_get mb in ReactiveHash.Map.iter_with f ctx inner; ReactiveHash.Map.remove t.outer ko; ReactiveHash.Map.clear inner; @@ -86,13 +86,12 @@ let find_inner_maybe t ko = ReactiveHash.Map.find_maybe t.outer ko let iter_inner_with t ko ctx f = let mb = ReactiveHash.Map.find_maybe t.outer ko in - if ReactiveMaybe.is_some mb then - ReactiveHash.Map.iter_with f ctx (ReactiveMaybe.unsafe_get mb) + if Maybe.is_some mb then + ReactiveHash.Map.iter_with f ctx (Maybe.unsafe_get mb) let inner_cardinal t ko = let mb = ReactiveHash.Map.find_maybe t.outer ko in - if ReactiveMaybe.is_some mb then - ReactiveHash.Map.cardinal (ReactiveMaybe.unsafe_get mb) + if Maybe.is_some mb then ReactiveHash.Map.cardinal (Maybe.unsafe_get mb) else 0 let outer_cardinal t = ReactiveHash.Map.cardinal t.outer diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/ReactivePoolMapMap.mli index f307f1349d7..40394943bd5 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.mli +++ b/analysis/reactive/src/ReactivePoolMapMap.mli @@ -24,7 +24,7 @@ val drain_outer : No-op if [ko] is absent. *) val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t ReactiveMaybe.t + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t (** Zero-allocation lookup of inner map by outer key. *) val iter_inner_with : diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml index d158b166a2f..4f868828544 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.ml +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -52,7 +52,7 @@ let pool_pop t = let ensure t k = let m = ReactiveHash.Map.find_maybe t.outer k in - if ReactiveMaybe.is_some m then ReactiveMaybe.unsafe_get m + if Maybe.is_some m then Maybe.unsafe_get m else let set = pool_pop t in ReactiveHash.Map.replace t.outer k set; @@ -64,8 +64,8 @@ let add t k v = let drain_key t k ctx f = let mb = ReactiveHash.Map.find_maybe t.outer k in - if ReactiveMaybe.is_some mb then ( - let set = ReactiveMaybe.unsafe_get mb in + if Maybe.is_some mb then ( + let set = Maybe.unsafe_get mb in ReactiveHash.Set.iter_with f ctx set; ReactiveHash.Map.remove t.outer k; ReactiveHash.Set.clear set; @@ -75,8 +75,8 @@ let drain_key t k ctx f = let remove_from_set_and_recycle_if_empty t k v = let mb = ReactiveHash.Map.find_maybe t.outer k in - if ReactiveMaybe.is_some mb then ( - let set = ReactiveMaybe.unsafe_get mb in + if Maybe.is_some mb then ( + let set = Maybe.unsafe_get mb in ReactiveHash.Set.remove set v; let after = ReactiveHash.Set.cardinal set in if after = 0 then ( diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli index a1309de69be..656358a104b 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.mli +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -20,7 +20,7 @@ val remove_from_set_and_recycle_if_empty : ('k, 'v) t -> 'k -> 'v -> unit (** [remove_from_set_and_recycle_if_empty t k v] removes [v] from [k]'s set. If the set becomes empty, [k] is recycled. No-op if [k] is absent. *) -val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveHash.Set.t ReactiveMaybe.t +val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveHash.Set.t Maybe.t (** Zero-allocation lookup. *) val iter_with : diff --git a/analysis/reactive/src/ReactiveSet.ml b/analysis/reactive/src/ReactiveSet.ml index 2183e047dbd..2d5c3e4d862 100644 --- a/analysis/reactive/src/ReactiveSet.ml +++ b/analysis/reactive/src/ReactiveSet.ml @@ -1,9 +1,9 @@ (* Representation of ['a t]: - - ['a t] is [('a, int, int) ReactiveAllocator.Block2.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 ReactiveAllocator.offheap]. + - Data slots: keys, stored as ['a Allocator.offheap]. The backing block lives off-heap. Elements are ordinary OCaml values whose storage invariant has already been established before insertion. @@ -13,7 +13,7 @@ - the distinguished tomb sentinel, meaning the slot was removed - a real set element. *) -type 'a t = ('a, int, int) ReactiveAllocator.Block2.t +type 'a t = ('a, int, int) Allocator.Block2.t let initial_capacity = 8 let max_load_percent = 82 @@ -21,82 +21,80 @@ 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 ReactiveAllocator.offheap) -let[@inline] tomb_sentinel = - fun () -> (Obj.magic tomb : 'a ReactiveAllocator.offheap) + fun () -> (Obj.magic sentinel : 'a Allocator.offheap) +let[@inline] tomb_sentinel = fun () -> (Obj.magic tomb : 'a Allocator.offheap) -let slot_capacity = ReactiveAllocator.Block2.capacity -let population = ReactiveAllocator.Block2.get0 -let set_population = ReactiveAllocator.Block2.set0 -let mask = ReactiveAllocator.Block2.get1 -let set_mask = ReactiveAllocator.Block2.set1 +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 (ReactiveAllocator.unsafe_from_offheap x) land mask t + Hashtbl.hash (Allocator.unsafe_from_offheap 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 - ReactiveAllocator.Block2.set t i (empty_sentinel ()) + Allocator.Block2.set t i (empty_sentinel ()) done let create () = let t = - ReactiveAllocator.Block2.create ~capacity:initial_capacity ~x0:0 + Allocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:(initial_capacity - 1) in clear_slots t; t -let destroy = ReactiveAllocator.Block2.destroy +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 ReactiveAllocator.offheap) = +let add_absent_key (type a) (t : a t) (x : a Allocator.offheap) = let j = ref (start t x) in while - let current = ReactiveAllocator.Block2.get t !j in + let current = Allocator.Block2.get t !j in current != empty_sentinel () && current != tomb_sentinel () do j := next t !j done; - ReactiveAllocator.Block2.set t !j x + 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 = - ReactiveAllocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:(old_cap - 1) + Allocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:(old_cap - 1) in - ReactiveAllocator.Block2.blit ~src:t ~src_pos:0 ~dst:old_keys ~dst_pos:0 - ~len:old_cap; - ReactiveAllocator.Block2.resize t ~capacity:new_cap; + 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 = ReactiveAllocator.Block2.get old_keys i in + let x = Allocator.Block2.get old_keys i in if x != empty_sentinel () && x != tomb_sentinel () then add_absent_key t x done; - ReactiveAllocator.Block2.destroy old_keys + 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 ReactiveAllocator.offheap) = +let add (type a) (t : a t) (x : a Allocator.offheap) = 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 = ReactiveAllocator.Block2.get t !j in + 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 - ReactiveAllocator.Block2.set t dst x; + Allocator.Block2.set t dst x; set_population t (population t + 1); found := true) else if current == tomb_sentinel () then ( @@ -106,26 +104,26 @@ let add (type a) (t : a t) (x : a ReactiveAllocator.offheap) = else j := next t !j done -let remove (type a) (t : a t) (x : a ReactiveAllocator.offheap) = +let remove (type a) (t : a t) (x : a Allocator.offheap) = let j = ref (start t x) in let done_ = ref false in while not !done_ do - let current = ReactiveAllocator.Block2.get t !j in + 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 ( - ReactiveAllocator.Block2.set t !j (tomb_sentinel ()); + 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 ReactiveAllocator.offheap) = +let mem (type a) (t : a t) (x : a Allocator.offheap) = let j = ref (start t x) in let found = ref false in let done_ = ref false in while not !done_ do - let current = ReactiveAllocator.Block2.get t !j in + 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 ( @@ -135,11 +133,11 @@ let mem (type a) (t : a t) (x : a ReactiveAllocator.offheap) = done; !found -let iter_with (type a k) (f : a -> k ReactiveAllocator.offheap -> unit) - (arg : a) (t : k t) = +let iter_with (type a k) (f : a -> k Allocator.offheap -> unit) (arg : a) + (t : k t) = if population t > 0 then for i = 0 to slot_capacity t - 1 do - let x = ReactiveAllocator.Block2.get t i in + let x = Allocator.Block2.get t i in if x != empty_sentinel () && x != tomb_sentinel () then f arg x done diff --git a/analysis/reactive/src/ReactiveSet.mli b/analysis/reactive/src/ReactiveSet.mli index ed5b995ff57..ea3113a05e0 100644 --- a/analysis/reactive/src/ReactiveSet.mli +++ b/analysis/reactive/src/ReactiveSet.mli @@ -1,7 +1,7 @@ (** Off-heap mutable sets for reactive internals. Elements are ordinary OCaml values. The set's backing storage lives in the - custom allocator via {!ReactiveAllocator.Block2}. *) + custom allocator via {!Allocator.Block2}. *) type 'a t @@ -15,17 +15,16 @@ val destroy : 'a t -> unit val clear : 'a t -> unit (** Remove all elements while keeping the current storage. *) -val add : 'a t -> 'a ReactiveAllocator.offheap -> unit +val add : 'a t -> 'a Allocator.offheap -> unit (** Add an element to the set. Re-adding an existing element is a no-op. *) -val remove : 'a t -> 'a ReactiveAllocator.offheap -> unit +val remove : 'a t -> 'a Allocator.offheap -> unit (** Remove an element from the set. Removing a missing element is a no-op. *) -val mem : 'a t -> 'a ReactiveAllocator.offheap -> bool +val mem : 'a t -> 'a Allocator.offheap -> bool (** Test whether the set contains an element. *) -val iter_with : - ('b -> 'a ReactiveAllocator.offheap -> unit) -> 'b -> 'a t -> unit +val iter_with : ('b -> 'a Allocator.offheap -> unit) -> 'b -> 'a t -> unit (** [iter_with f arg t] calls [f arg x] for each element. *) val cardinal : 'a t -> int diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml index f9ffb0a34fd..83b7494f9b4 100644 --- a/analysis/reactive/src/ReactiveTable.ml +++ b/analysis/reactive/src/ReactiveTable.ml @@ -1,26 +1,22 @@ -type 'a t = ReactiveAllocator.Block.t +type 'a t = Allocator.Block.t let length_slot = 0 let data_offset = 1 let length t : int = - ReactiveAllocator.unsafe_from_offheap - (ReactiveAllocator.Block.get t length_slot) + Allocator.unsafe_from_offheap (Allocator.Block.get t length_slot) -let capacity t = ReactiveAllocator.Block.capacity t - data_offset +let capacity t = Allocator.Block.capacity t - data_offset let create ~initial_capacity = if initial_capacity < 0 then invalid_arg "ReactiveTable.create"; - let t = - ReactiveAllocator.Block.create ~capacity:(initial_capacity + data_offset) - in - ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.int_to_offheap 0); + let t = Allocator.Block.create ~capacity:(initial_capacity + data_offset) in + Allocator.Block.set t length_slot (Allocator.int_to_offheap 0); t -let destroy = ReactiveAllocator.Block.destroy +let destroy = Allocator.Block.destroy -let clear t = - ReactiveAllocator.Block.set t length_slot (ReactiveAllocator.int_to_offheap 0) +let clear t = Allocator.Block.set t length_slot (Allocator.int_to_offheap 0) let ensure_capacity t needed = let old_capacity = capacity t in @@ -29,33 +25,30 @@ let ensure_capacity t needed = while !new_capacity < needed do new_capacity := !new_capacity * 2 done; - ReactiveAllocator.Block.resize t ~capacity:(!new_capacity + data_offset)) + Allocator.Block.resize t ~capacity:(!new_capacity + data_offset)) let get t index = let len = length t in if index < 0 || index >= len then invalid_arg "ReactiveTable.get"; - ReactiveAllocator.Block.get t (index + data_offset) + Allocator.Block.get t (index + data_offset) let set t index value = let len = length t in if index < 0 || index >= len then invalid_arg "ReactiveTable.set"; - ReactiveAllocator.Block.set t (index + data_offset) value + Allocator.Block.set t (index + data_offset) value let push t value = let len = length t in let next_len = len + 1 in ensure_capacity t next_len; - ReactiveAllocator.Block.set t (len + data_offset) value; - ReactiveAllocator.Block.set t length_slot - (ReactiveAllocator.int_to_offheap next_len) + Allocator.Block.set t (len + data_offset) value; + Allocator.Block.set t length_slot (Allocator.int_to_offheap next_len) let pop t = let len = length t in if len = 0 then invalid_arg "ReactiveTable.pop"; - let last = ReactiveAllocator.Block.get t (len - 1 + data_offset) in - ReactiveAllocator.Block.set t length_slot - (ReactiveAllocator.int_to_offheap (len - 1)); + let last = Allocator.Block.get t (len - 1 + data_offset) in + Allocator.Block.set t length_slot (Allocator.int_to_offheap (len - 1)); last -let shrink_to_fit t = - ReactiveAllocator.Block.resize t ~capacity:(length t + data_offset) +let shrink_to_fit t = Allocator.Block.resize t ~capacity:(length t + data_offset) diff --git a/analysis/reactive/src/ReactiveTable.mli b/analysis/reactive/src/ReactiveTable.mli index 0249cdfc7cc..d67480a9cd8 100644 --- a/analysis/reactive/src/ReactiveTable.mli +++ b/analysis/reactive/src/ReactiveTable.mli @@ -32,13 +32,13 @@ val capacity : 'a t -> int val clear : 'a t -> unit (** Remove all elements from the table without releasing its storage. *) -val get : 'a t -> int -> 'a ReactiveAllocator.offheap -val set : 'a t -> int -> 'a ReactiveAllocator.offheap -> unit +val get : 'a t -> int -> 'a Allocator.offheap +val set : 'a t -> int -> 'a Allocator.offheap -> unit -val push : 'a t -> 'a ReactiveAllocator.offheap -> unit +val push : 'a t -> 'a Allocator.offheap -> unit (** Append an element, growing via the allocator when needed. *) -val pop : 'a t -> 'a ReactiveAllocator.offheap +val pop : 'a t -> 'a Allocator.offheap (** Remove and return the last element. *) val shrink_to_fit : 'a t -> unit diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index bc479cec7ec..8112b4c6a0d 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -5,10 +5,10 @@ type ('k, 'v) t = { left_values: ('k, 'v) ReactiveMap.t; right_values: ('k, 'v) ReactiveMap.t; target: ('k, 'v) ReactiveMap.t; - left_scratch: ('k, 'v ReactiveMaybe.t) ReactiveMap.t; - right_scratch: ('k, 'v ReactiveMaybe.t) ReactiveMap.t; + left_scratch: ('k, 'v Maybe.t) ReactiveMap.t; + right_scratch: ('k, 'v Maybe.t) ReactiveMap.t; affected: 'k ReactiveSet.t; - output_wave: ('k, 'v ReactiveMaybe.t) ReactiveWave.t; + output_wave: ('k, 'v Maybe.t) ReactiveWave.t; result: process_result; } @@ -60,85 +60,80 @@ let push_right t k mv = ReactiveMap.replace t.right_scratch k mv (* Module-level helpers for iter_with — avoid closure allocation *) let apply_left_entry t k mv = - let k = ReactiveAllocator.unsafe_from_offheap k in - let mv = ReactiveAllocator.unsafe_from_offheap mv in + let k = Allocator.unsafe_from_offheap k in + let mv = Allocator.unsafe_from_offheap mv in let r = t.result in r.entries_received <- r.entries_received + 1; - if ReactiveMaybe.is_some mv then ( + if Maybe.is_some mv then ( ReactiveMap.replace t.left_values - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.unsafe_get mv)); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.left_values (ReactiveAllocator.unsafe_to_offheap k); + ReactiveMap.remove t.left_values (Allocator.unsafe_to_offheap k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k) + ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k) let apply_right_entry t k mv = - let k = ReactiveAllocator.unsafe_from_offheap k in - let mv = ReactiveAllocator.unsafe_from_offheap mv in + let k = Allocator.unsafe_from_offheap k in + let mv = Allocator.unsafe_from_offheap mv in let r = t.result in r.entries_received <- r.entries_received + 1; - if ReactiveMaybe.is_some mv then ( + if Maybe.is_some mv then ( ReactiveMap.replace t.right_values - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.unsafe_get mv)); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.right_values (ReactiveAllocator.unsafe_to_offheap k); + ReactiveMap.remove t.right_values (Allocator.unsafe_to_offheap k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (ReactiveAllocator.unsafe_to_offheap k) + ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k) let recompute_affected_entry t k = - let k = ReactiveAllocator.unsafe_from_offheap k in + let k = Allocator.unsafe_from_offheap k in let r = t.result in let lv = - ReactiveMap.find_maybe t.left_values (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMap.find_maybe t.left_values (Allocator.unsafe_to_offheap k) in let rv = - ReactiveMap.find_maybe t.right_values - (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMap.find_maybe t.right_values (Allocator.unsafe_to_offheap k) in - let has_left = ReactiveMaybe.is_some lv in - let has_right = ReactiveMaybe.is_some rv 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 - (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get lv)) - (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get rv)) + (Allocator.unsafe_from_offheap (Maybe.unsafe_get lv)) + (Allocator.unsafe_from_offheap (Maybe.unsafe_get rv)) in ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap merged); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap merged); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some merged))) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.some merged))) else - let v = - ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get lv) - in + let v = Allocator.unsafe_from_offheap (Maybe.unsafe_get lv) in ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap v); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap v); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.some v))) else if has_right then ( - let v = - ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get rv) - in + let v = Allocator.unsafe_from_offheap (Maybe.unsafe_get rv) in ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap v); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap v); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.some v))) else ( - ReactiveMap.remove t.target (ReactiveAllocator.unsafe_to_offheap k); + ReactiveMap.remove t.target (Allocator.unsafe_to_offheap k); ReactiveWave.push t.output_wave - (ReactiveAllocator.unsafe_to_offheap k) - ReactiveMaybe.none_offheap); + (Allocator.unsafe_to_offheap k) + Maybe.none_offheap); 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 @@ -167,43 +162,39 @@ let process t = let init_left t k v = ReactiveMap.replace t.left_values - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap v); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap v); ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap v) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap v) let init_right t k v = ReactiveMap.replace t.right_values - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap v); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap v); let lv = - ReactiveMap.find_maybe t.left_values (ReactiveAllocator.unsafe_to_offheap k) + ReactiveMap.find_maybe t.left_values (Allocator.unsafe_to_offheap k) in let merged = - if ReactiveMaybe.is_some lv then - t.merge - (ReactiveAllocator.unsafe_from_offheap (ReactiveMaybe.unsafe_get lv)) - v + if Maybe.is_some lv then + t.merge (Allocator.unsafe_from_offheap (Maybe.unsafe_get lv)) v else v in ReactiveMap.replace t.target - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap merged) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap merged) let iter_target f t = ReactiveMap.iter (fun k v -> - f - (ReactiveAllocator.unsafe_from_offheap k) - (ReactiveAllocator.unsafe_from_offheap v)) + f (Allocator.unsafe_from_offheap k) (Allocator.unsafe_from_offheap v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (ReactiveAllocator.unsafe_to_offheap k) - |> ReactiveMaybe.to_option + ReactiveMap.find_maybe t.target (Allocator.unsafe_to_offheap k) + |> Maybe.to_option |> function - | Some v -> ReactiveMaybe.some (ReactiveAllocator.unsafe_from_offheap v) - | None -> ReactiveMaybe.none + | Some v -> Maybe.some (Allocator.unsafe_from_offheap v) + | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index 386d21e1d26..6f68273aa28 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -20,21 +20,15 @@ val destroy : ('k, 'v) t -> unit (** Release union-owned off-heap storage. The state must not be used afterwards. *) -val output_wave : ('k, 'v) t -> ('k, 'v ReactiveMaybe.t) ReactiveWave.t +val output_wave : ('k, 'v) t -> ('k, 'v Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) val push_left : - ('k, 'v) t -> - 'k ReactiveAllocator.offheap -> - 'v ReactiveMaybe.t ReactiveAllocator.offheap -> - unit + ('k, 'v) t -> 'k Allocator.offheap -> 'v Maybe.t Allocator.offheap -> unit (** Push an entry into the left scratch table. *) val push_right : - ('k, 'v) t -> - 'k ReactiveAllocator.offheap -> - 'v ReactiveMaybe.t ReactiveAllocator.offheap -> - unit + ('k, 'v) t -> 'k Allocator.offheap -> 'v Maybe.t Allocator.offheap -> unit (** Push an entry into the right scratch table. *) val process : ('k, 'v) t -> process_result @@ -49,5 +43,5 @@ val init_right : ('k, 'v) t -> 'k -> 'v -> unit (** Initialize a right entry (during setup, after left). *) val iter_target : ('k -> 'v -> unit) -> ('k, 'v) t -> unit -val find_target : ('k, 'v) t -> 'k -> 'v ReactiveMaybe.t +val find_target : ('k, 'v) t -> 'k -> 'v Maybe.t val target_length : ('k, 'v) t -> int diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index 4aac4a47892..cecadffcc7f 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -1,72 +1,62 @@ -type ('k, 'v) t = ReactiveAllocator.Block.t +type ('k, 'v) t = Allocator.Block.t let length_slot = 0 let data_offset = 1 let entry_width = 2 let length t : int = - ReactiveAllocator.unsafe_from_offheap - (ReactiveAllocator.Block.get t length_slot) + Allocator.unsafe_from_offheap (Allocator.Block.get t length_slot) let set_length t len = - ReactiveAllocator.Block.set t length_slot - (ReactiveAllocator.int_to_offheap len) + Allocator.Block.set t length_slot (Allocator.int_to_offheap len) let create ?(max_entries = 16) () = if max_entries < 0 then invalid_arg "ReactiveWave.create: max_entries must be >= 0"; let t = - ReactiveAllocator.Block.create - ~capacity:(data_offset + (max_entries * entry_width)) + Allocator.Block.create ~capacity:(data_offset + (max_entries * entry_width)) in set_length t 0; t let clear t = set_length t 0 -let destroy t = ReactiveAllocator.Block.destroy t +let destroy t = Allocator.Block.destroy t let ensure_capacity t needed = - let current = - (ReactiveAllocator.Block.capacity t - data_offset) / entry_width - in + let current = (Allocator.Block.capacity t - data_offset) / entry_width in if needed > current then ( let next = ref (max 1 current) in while !next < needed do next := !next * 2 done; - ReactiveAllocator.Block.resize t - ~capacity:(data_offset + (!next * entry_width))) + Allocator.Block.resize t ~capacity:(data_offset + (!next * entry_width))) -let push (type k v) (t : (k, v) t) (k : k ReactiveAllocator.offheap) - (v : v ReactiveAllocator.offheap) = +let push (type k v) (t : (k, v) t) (k : k Allocator.offheap) + (v : v Allocator.offheap) = let len = length t in ensure_capacity t (len + 1); let key_slot = data_offset + (len * entry_width) in - ReactiveAllocator.Block.set t key_slot k; - ReactiveAllocator.Block.set t (key_slot + 1) v; + Allocator.Block.set t key_slot k; + Allocator.Block.set t (key_slot + 1) v; set_length t (len + 1) let iter (type k v) (t : (k, v) t) - (f : k ReactiveAllocator.offheap -> v ReactiveAllocator.offheap -> unit) = + (f : k Allocator.offheap -> v Allocator.offheap -> unit) = let len = length t in for i = 0 to len - 1 do let key_slot = data_offset + (i * entry_width) in - f - (ReactiveAllocator.Block.get t key_slot) - (ReactiveAllocator.Block.get t (key_slot + 1)) + f (Allocator.Block.get t key_slot) (Allocator.Block.get t (key_slot + 1)) done let iter_with (type a k v) (t : (k, v) t) - (f : - a -> k ReactiveAllocator.offheap -> v ReactiveAllocator.offheap -> unit) - (arg : a) = + (f : a -> k Allocator.offheap -> v Allocator.offheap -> unit) (arg : a) = let len = length t in for i = 0 to len - 1 do let key_slot = data_offset + (i * entry_width) in f arg - (ReactiveAllocator.Block.get t key_slot) - (ReactiveAllocator.Block.get t (key_slot + 1)) + (Allocator.Block.get t key_slot) + (Allocator.Block.get t (key_slot + 1)) done let count t = length t diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli index 9b5d630f4cc..211435ea49e 100644 --- a/analysis/reactive/src/ReactiveWave.mli +++ b/analysis/reactive/src/ReactiveWave.mli @@ -1,6 +1,6 @@ (** A wave is a growable batch of key/value entries stored in off-heap allocator-backed storage. Its API is marked with - [ReactiveAllocator.offheap] so call sites make the boundary explicit. + [Allocator.offheap] 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. *) @@ -16,22 +16,16 @@ val clear : ('k, 'v) t -> unit val destroy : ('k, 'v) t -> unit (** Release the wave's off-heap storage. The wave must not be used after this. *) -val push : - ('k, 'v) t -> - 'k ReactiveAllocator.offheap -> - 'v ReactiveAllocator.offheap -> - unit +val push : ('k, 'v) t -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit (** Append one off-heap-marked entry to the wave. Callers are currently responsible for establishing the off-heap invariant before calling. *) val iter : - ('k, 'v) t -> - ('k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> - unit + ('k, 'v) t -> ('k Allocator.offheap -> 'v Allocator.offheap -> unit) -> unit val iter_with : ('k, 'v) t -> - ('a -> 'k ReactiveAllocator.offheap -> 'v ReactiveAllocator.offheap -> unit) -> + ('a -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit) -> 'a -> unit (** [iter_with t f arg] calls [f arg k v] for each entry. diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 741f201ac1a..f2b99759ca5 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -7,30 +7,30 @@ open TestHelpers let words_since = AllocMeasure.words_since -let off = ReactiveAllocator.unsafe_to_offheap -let off_int = ReactiveAllocator.int_to_offheap -let off_unit = ReactiveAllocator.unit_to_offheap -let off_maybe_int = ReactiveMaybe.maybe_int_to_offheap -let off_maybe_unit = ReactiveMaybe.maybe_unit_to_offheap +let off = Allocator.unsafe_to_offheap +let off_int = Allocator.int_to_offheap +let off_unit = Allocator.unit_to_offheap +let off_maybe_int = Maybe.maybe_int_to_offheap +let off_maybe_unit = Maybe.maybe_unit_to_offheap let unsafe_wave_push wave k v = ReactiveWave.push wave (off k) (off v) let print_offheap_usage () = - let blocks = ReactiveAllocator.live_block_count () in - let slots = ReactiveAllocator.live_block_capacity_slots () in - let bytes = slots * ReactiveAllocator.slot_size_bytes in + 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 " offheap: blocks=%d slots=%d bytes=%d\n" blocks slots bytes let reset_offheap_state () = Reactive.reset (); - ReactiveAllocator.reset (); - assert (ReactiveAllocator.live_block_count () = 0); - assert (ReactiveAllocator.live_block_capacity_slots () = 0) + Allocator.reset (); + assert (Allocator.live_block_count () = 0); + assert (Allocator.live_block_capacity_slots () = 0) let print_offheap_snapshot label = - let blocks = ReactiveAllocator.live_block_count () in - let slots = ReactiveAllocator.live_block_capacity_slots () in - let bytes = slots * ReactiveAllocator.slot_size_bytes in + 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 ---- *) @@ -49,15 +49,14 @@ let test_fixpoint_alloc_n n = ReactiveWave.push root_snap (off_int 0) (off_unit ()); for i = 0 to n - 2 do ReactiveWave.push edge_snap (off_int i) - (ReactiveAllocator.to_offheap edge_values.(i)) + (Allocator.to_offheap edge_values.(i)) done; ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; assert (ReactiveFixpoint.current_length state = n); (* Pre-build waves once *) - ReactiveWave.push remove_root (off_int 0) ReactiveMaybe.none_offheap; - ReactiveWave.push add_root (off_int 0) - (off_maybe_unit (ReactiveMaybe.some ())); + ReactiveWave.push remove_root (off_int 0) Maybe.none_offheap; + ReactiveWave.push add_root (off_int 0) (off_maybe_unit (Maybe.some ())); (* Warmup *) for _ = 1 to 5 do @@ -102,8 +101,7 @@ let test_flatmap_alloc_n n = (* Populate: n entries *) for i = 0 to n - 1 do - ReactiveFlatMap.push state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveFlatMap.push state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n); @@ -111,13 +109,12 @@ let test_flatmap_alloc_n 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 (off i) ReactiveMaybe.none_offheap + ReactiveFlatMap.push state (off i) Maybe.none_offheap done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = 0); for i = 0 to n - 1 do - ReactiveFlatMap.push state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveFlatMap.push state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n) @@ -128,12 +125,11 @@ let test_flatmap_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveFlatMap.push state (off i) ReactiveMaybe.none_offheap + ReactiveFlatMap.push state (off i) Maybe.none_offheap done; ignore (ReactiveFlatMap.process state); for i = 0 to n - 1 do - ReactiveFlatMap.push state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveFlatMap.push state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveFlatMap.process state) done; @@ -159,8 +155,7 @@ let test_union_alloc_n n = (* Populate: n entries on the left side *) for i = 0 to n - 1 do - ReactiveUnion.push_left state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveUnion.push_left state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n); @@ -168,13 +163,12 @@ let test_union_alloc_n 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 (off i) ReactiveMaybe.none_offheap + ReactiveUnion.push_left state (off i) Maybe.none_offheap done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = 0); for i = 0 to n - 1 do - ReactiveUnion.push_left state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveUnion.push_left state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n) @@ -185,12 +179,11 @@ let test_union_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveUnion.push_left state (off i) ReactiveMaybe.none_offheap + ReactiveUnion.push_left state (off i) Maybe.none_offheap done; ignore (ReactiveUnion.process state); for i = 0 to n - 1 do - ReactiveUnion.push_left state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveUnion.push_left state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveUnion.process state) done; @@ -217,8 +210,7 @@ let test_join_alloc_n n = ReactiveJoin.create ~key_of:(fun k _v -> k) ~f:(fun k v right_mb emit -> - if ReactiveMaybe.is_some right_mb then - emit k (v + ReactiveMaybe.unsafe_get right_mb)) + if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) ~merge:(fun _l r -> r) ~right_get:(ReactiveHash.Map.find_maybe right_tbl) in @@ -228,8 +220,7 @@ let test_join_alloc_n n = ReactiveHash.Map.replace right_tbl i (i * 10) done; for i = 0 to n - 1 do - ReactiveJoin.push_left state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveJoin.push_left state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n); @@ -237,13 +228,12 @@ let test_join_alloc_n n = (* Warmup: toggle all left entries *) for _ = 1 to 5 do for i = 0 to n - 1 do - ReactiveJoin.push_left state (off i) ReactiveMaybe.none_offheap + ReactiveJoin.push_left state (off i) Maybe.none_offheap done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = 0); for i = 0 to n - 1 do - ReactiveJoin.push_left state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveJoin.push_left state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n) @@ -254,12 +244,11 @@ let test_join_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveJoin.push_left state (off i) ReactiveMaybe.none_offheap + ReactiveJoin.push_left state (off i) Maybe.none_offheap done; ignore (ReactiveJoin.process state); for i = 0 to n - 1 do - ReactiveJoin.push_left state (off_int i) - (off_maybe_int (ReactiveMaybe.some i)) + ReactiveJoin.push_left state (off_int i) (off_maybe_int (Maybe.some i)) done; ignore (ReactiveJoin.process state) done; @@ -290,8 +279,7 @@ let test_reactive_join_alloc_n n = Reactive.Join.create ~name:"joined" left right ~key_of:(fun k _v -> k) ~f:(fun k v right_mb emit -> - if ReactiveMaybe.is_some right_mb then - emit k (v + ReactiveMaybe.unsafe_get right_mb)) + if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) () in @@ -307,11 +295,11 @@ let test_reactive_join_alloc_n n = (* Pre-build waves for the hot loop: toggle all left entries *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap + ReactiveWave.push remove_wave (off i) Maybe.none_offheap done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - unsafe_wave_push add_wave i (ReactiveMaybe.some i) + unsafe_wave_push add_wave i (Maybe.some i) done; (* Warmup *) @@ -362,8 +350,7 @@ let test_reactive_fixpoint_alloc_n n = ReactiveWave.clear edge_wave; for i = 0 to n - 2 do ReactiveWave.push edge_wave (off_int i) - (ReactiveMaybe.maybe_offheap_list_to_offheap - (ReactiveMaybe.some edge_values_offheap.(i))) + (Maybe.maybe_offheap_list_to_offheap (Maybe.some edge_values_offheap.(i))) done; emit_edges edge_wave; let reachable = Reactive.Fixpoint.create ~name:"reachable" ~init ~edges () in @@ -374,10 +361,9 @@ let test_reactive_fixpoint_alloc_n n = (* Pre-build waves for the hot loop *) let remove_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push remove_wave (off_int 0) ReactiveMaybe.none_offheap; + ReactiveWave.push remove_wave (off_int 0) Maybe.none_offheap; let add_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push add_wave (off_int 0) - (off_maybe_unit (ReactiveMaybe.some ())); + ReactiveWave.push add_wave (off_int 0) (off_maybe_unit (Maybe.some ())); (* Warmup *) for _ = 1 to 5 do @@ -430,11 +416,11 @@ let test_reactive_union_alloc_n n = (* Pre-build waves: single wave with all n entries *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap + ReactiveWave.push remove_wave (off i) Maybe.none_offheap done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - unsafe_wave_push add_wave i (ReactiveMaybe.some i) + unsafe_wave_push add_wave i (Maybe.some i) done; (* Warmup *) @@ -489,11 +475,11 @@ let test_reactive_flatmap_alloc_n n = (* Pre-build waves *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (off i) ReactiveMaybe.none_offheap + ReactiveWave.push remove_wave (off i) Maybe.none_offheap done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - unsafe_wave_push add_wave i (ReactiveMaybe.some i) + unsafe_wave_push add_wave i (Maybe.some i) done; (* Warmup *) diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 81afb2729f2..909497e7b44 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -54,8 +54,7 @@ let test_batch_fixpoint () = | entries -> incr batch_count; entries - |> List.iter (fun (_, mv) -> - if ReactiveMaybe.is_some mv then incr total_added)) + |> List.iter (fun (_, mv) -> if Maybe.is_some mv then incr total_added)) fp; (* Set up edges first *) diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/FixpointIncrementalTest.ml index 497a7556381..09fcbb48552 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -29,7 +29,7 @@ let test_fixpoint_add_base () = | entries -> entries |> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed)) fp; @@ -67,7 +67,7 @@ let test_fixpoint_remove_base () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -97,7 +97,7 @@ let test_fixpoint_add_edge () = (function | entries -> List.iter - (fun (k, mv) -> if ReactiveMaybe.is_some mv then added := k :: !added) + (fun (k, mv) -> if Maybe.is_some mv then added := k :: !added) entries) fp; @@ -132,7 +132,7 @@ let test_fixpoint_remove_edge () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -170,7 +170,7 @@ let test_fixpoint_cycle_removal () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -210,7 +210,7 @@ let test_fixpoint_alternative_support () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -286,7 +286,7 @@ let test_fixpoint_remove_spurious_root () = | entries -> entries |> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed)) fp; @@ -362,7 +362,7 @@ let test_fixpoint_remove_edge_entry_alternative_source () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -412,7 +412,7 @@ let test_fixpoint_remove_edge_rederivation () = | entries -> entries |> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed)) fp; @@ -471,7 +471,7 @@ let test_fixpoint_remove_edge_entry_rederivation () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -521,7 +521,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = | entries -> entries |> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed)) fp; @@ -591,7 +591,7 @@ let test_fixpoint_remove_edge_entry_needs_rederivation () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -636,7 +636,7 @@ let test_fixpoint_remove_base_needs_rederivation () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -673,7 +673,7 @@ let test_fixpoint_batch_overlapping_deletions () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -716,7 +716,7 @@ let test_fixpoint_batch_delete_add_same_wave () = | entries -> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed) entries) fp; @@ -760,7 +760,7 @@ let test_fixpoint_fanin_single_predecessor_removed () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -801,7 +801,7 @@ let test_fixpoint_cycle_alternative_external_support () = | entries -> List.iter (fun (k, mv) -> - if not (ReactiveMaybe.is_some mv) then removed := k :: !removed) + if not (Maybe.is_some mv) then removed := k :: !removed) entries) fp; @@ -857,7 +857,7 @@ let test_fixpoint_remove_then_readd_via_expansion_same_wave () = | entries -> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed) entries) fp; diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index ed05440bfad..b58229631d7 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -19,8 +19,8 @@ let track_deltas c = c.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> - let k = ReactiveAllocator.unsafe_from_offheap k in - let mv = ReactiveAllocator.unsafe_from_offheap mv in + let k = Allocator.unsafe_from_offheap k in + let mv = Allocator.unsafe_from_offheap mv in rev_entries := (k, mv) :: !rev_entries); received := List.rev !rev_entries :: !received); received @@ -30,7 +30,7 @@ let count_delta = function | entries -> List.fold_left (fun (a, r) (_, mv) -> - if ReactiveMaybe.is_some mv then (a + 1, r) else (a, r + 1)) + if Maybe.is_some mv then (a + 1, r) else (a, r + 1)) (0, 0) entries let sum_deltas deltas = @@ -65,7 +65,7 @@ let test_same_source_anti_join () = Join.create ~name:"external_refs" refs decls ~key_of:(fun posFrom _posTo -> posFrom) ~f:(fun _posFrom posTo decl_mb emit -> - if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) + if not (Maybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () in @@ -134,7 +134,7 @@ let test_multi_level_union () = Join.create ~name:"external_refs" all_refs decls ~key_of:(fun posFrom _posTo -> posFrom) ~f:(fun _posFrom posTo decl_mb emit -> - if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) + if not (Maybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () in @@ -197,7 +197,7 @@ let test_real_pipeline_simulation () = exception_decls ~key_of:(fun path _loc -> path) ~f:(fun path loc decl_mb emit -> - if ReactiveMaybe.is_some decl_mb then emit path loc) + if Maybe.is_some decl_mb then emit path loc) () in @@ -218,7 +218,7 @@ let test_real_pipeline_simulation () = Join.create ~name:"external_value_refs" value_refs_from decls ~key_of:(fun posFrom _posTo -> posFrom) ~f:(fun _posFrom posTo decl_mb emit -> - if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) + if not (Maybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () in @@ -250,7 +250,7 @@ let test_separate_sources () = Join.create ~name:"external_refs" refs_src decls_src ~key_of:(fun posFrom _posTo -> posFrom) ~f:(fun _posFrom posTo decl_mb emit -> - if not (ReactiveMaybe.is_some decl_mb) then emit posTo ()) + if not (Maybe.is_some decl_mb) then emit posTo ()) ~merge:(fun () () -> ()) () in diff --git a/analysis/reactive/test/JoinTest.ml b/analysis/reactive/test/JoinTest.ml index d5962d2201f..c3ba233bb7f 100644 --- a/analysis/reactive/test/JoinTest.ml +++ b/analysis/reactive/test/JoinTest.ml @@ -18,8 +18,8 @@ let test_join () = Join.create ~name:"joined" left right ~key_of:(fun path _loc_from -> path) ~f:(fun _path loc_from decl_pos_mb emit -> - if ReactiveMaybe.is_some decl_pos_mb then - emit (ReactiveMaybe.unsafe_get decl_pos_mb) loc_from) + if Maybe.is_some decl_pos_mb then + emit (Maybe.unsafe_get decl_pos_mb) loc_from) () in @@ -84,8 +84,7 @@ let test_join_with_merge () = Join.create ~name:"joined" left right ~key_of:(fun _id path -> path) (* Look up by path *) ~f:(fun _id _path value_mb emit -> - if ReactiveMaybe.is_some value_mb then - emit 0 (ReactiveMaybe.unsafe_get value_mb)) + if Maybe.is_some value_mb then emit 0 (Maybe.unsafe_get value_mb)) ~merge:( + ) (* Sum values *) () in diff --git a/analysis/reactive/test/TableTest.ml b/analysis/reactive/test/TableTest.ml index 2d7bdec9dcb..ef2fea37e03 100644 --- a/analysis/reactive/test/TableTest.ml +++ b/analysis/reactive/test/TableTest.ml @@ -5,10 +5,8 @@ let test_table_promoted_wave_lifecycle () = let iterations = 8 in let count = 128 in let width = 48 in - let initial_live_blocks = ReactiveAllocator.live_block_count () in - let initial_live_block_slots = - ReactiveAllocator.live_block_capacity_slots () - in + let initial_live_blocks = Allocator.live_block_count () in + let initial_live_block_slots = Allocator.live_block_capacity_slots () in Gc.full_major (); ignore (AllocMeasure.words_since ()); let t = ReactiveTable.create ~initial_capacity:1 in @@ -28,38 +26,34 @@ let test_table_promoted_wave_lifecycle () = assert (produced_words > 0); for i = 0 to count - 1 do - assert (ReactiveAllocator.is_in_minor_heap fresh.(i)) + assert (Allocator.is_in_minor_heap fresh.(i)) done; Gc.full_major (); for i = 0 to count - 1 do - assert (not (ReactiveAllocator.is_in_minor_heap fresh.(i))) + assert (not (Allocator.is_in_minor_heap fresh.(i))) done; ignore (AllocMeasure.words_since ()); ReactiveTable.clear t; for i = 0 to count - 1 do - ReactiveTable.push t (ReactiveAllocator.to_offheap fresh.(i)) + ReactiveTable.push t (Allocator.to_offheap fresh.(i)) done; assert (ReactiveTable.length t = count); assert (ReactiveTable.capacity t >= ReactiveTable.length t); - ReactiveTable.set t 0 (ReactiveAllocator.to_offheap fresh.(count - 1)); + ReactiveTable.set t 0 (Allocator.to_offheap fresh.(count - 1)); assert ( - ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t 0) - == fresh.(count - 1)); + Allocator.unsafe_from_offheap (ReactiveTable.get t 0) == fresh.(count - 1)); for i = 0 to count - 1 do let expected = if i = 0 then fresh.(count - 1) else fresh.(i) in - let recovered = - ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t i) - in + let recovered = Allocator.unsafe_from_offheap (ReactiveTable.get t i) in assert (recovered == expected); assert (Bytes.get recovered 0 = Bytes.get expected 0); assert (Bytes.get recovered (width - 1) = Bytes.get expected (width - 1)) done; assert ( - ReactiveAllocator.unsafe_from_offheap (ReactiveTable.pop t) - == fresh.(count - 1)); + Allocator.unsafe_from_offheap (ReactiveTable.pop t) == fresh.(count - 1)); assert (ReactiveTable.length t = count - 1); ReactiveTable.shrink_to_fit t; assert (ReactiveTable.capacity t = ReactiveTable.length t); @@ -76,9 +70,8 @@ let test_table_promoted_wave_lifecycle () = ReactiveTable.destroy t; let teardown_words = AllocMeasure.words_since () in assert (teardown_words = 0); - assert (ReactiveAllocator.live_block_count () = initial_live_blocks); - assert ( - ReactiveAllocator.live_block_capacity_slots () = initial_live_block_slots); + assert (Allocator.live_block_count () = initial_live_blocks); + assert (Allocator.live_block_capacity_slots () = initial_live_block_slots); Printf.printf " create=%d teardown=%d\n" create_words teardown_words; Printf.printf "PASSED\n\n" @@ -99,7 +92,7 @@ let test_table_unsafe_minor_heap_demo () = let fresh = Bytes.make width c in Bytes.set fresh 0 c; Bytes.set fresh (width - 1) c; - ReactiveTable.push t (ReactiveAllocator.unsafe_to_offheap fresh) + ReactiveTable.push t (Allocator.unsafe_to_offheap fresh) done; Gc.compact (); for round = 1 to 200 do @@ -118,7 +111,7 @@ let test_table_unsafe_minor_heap_demo () = for i = 0 to count - 1 do let expected = Char.chr ((i mod 26) + Char.code 'A') in let recovered : bytes = - ReactiveAllocator.unsafe_from_offheap (ReactiveTable.get t i) + Allocator.unsafe_from_offheap (ReactiveTable.get t i) in let ok = Bytes.length recovered = width diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 9024c67cf82..c9cf9aa9a55 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -17,8 +17,8 @@ let emit_set emit k v = let w = wave () in ReactiveWave.clear w; ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)); + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.some v)); emit w (** Emit a single edge-set entry, converting the successor list to the @@ -27,18 +27,16 @@ let emit_edge_set emit k vs = let w = wave () in ReactiveWave.clear w; ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveMaybe.maybe_offheap_list_to_offheap - (ReactiveMaybe.some (ReactiveOffheapList.unsafe_of_list vs))); + (Allocator.unsafe_to_offheap k) + (Maybe.maybe_offheap_list_to_offheap + (Maybe.some (ReactiveOffheapList.unsafe_of_list vs))); emit w (** Emit a single remove entry *) let emit_remove emit k = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - ReactiveMaybe.none_offheap; + ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap; emit w (** Emit a batch of (key, value) set entries *) @@ -48,8 +46,8 @@ let emit_sets emit entries = List.iter (fun (k, v) -> ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v))) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.some v))) entries; emit w @@ -62,12 +60,10 @@ let emit_batch emit entries = match v_opt with | Some v -> ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveAllocator.unsafe_to_offheap (ReactiveMaybe.some v)) + (Allocator.unsafe_to_offheap k) + (Allocator.unsafe_to_offheap (Maybe.some v)) | None -> - ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - ReactiveMaybe.none_offheap) + ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap) entries; emit w @@ -80,13 +76,11 @@ let emit_edge_batch emit entries = match vs_opt with | Some vs -> ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - (ReactiveMaybe.maybe_offheap_list_to_offheap - (ReactiveMaybe.some (ReactiveOffheapList.unsafe_of_list vs))) + (Allocator.unsafe_to_offheap k) + (Maybe.maybe_offheap_list_to_offheap + (Maybe.some (ReactiveOffheapList.unsafe_of_list vs))) | None -> - ReactiveWave.push w - (ReactiveAllocator.unsafe_to_offheap k) - ReactiveMaybe.none_offheap) + ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap) entries; emit w @@ -97,8 +91,8 @@ let subscribe handler t = t.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> - let k = ReactiveAllocator.unsafe_from_offheap k in - let mv = ReactiveAllocator.unsafe_from_offheap mv in + let k = Allocator.unsafe_from_offheap k in + let mv = Allocator.unsafe_from_offheap mv in rev_entries := (k, mv) :: !rev_entries); handler (List.rev !rev_entries)) @@ -110,7 +104,7 @@ let[@warning "-32"] track_changes () = | entries -> List.iter (fun (k, mv) -> - if ReactiveMaybe.is_some mv then added := k :: !added + if Maybe.is_some mv then added := k :: !added else removed := k :: !removed) entries in @@ -137,7 +131,7 @@ let[@warning "-32"] write_lines path lines = (** {1 Maybe/option helpers} *) (** Convert [get] result to option for test assertions *) -let get_opt t k = ReactiveMaybe.to_option (get t k) +let get_opt t k = Maybe.to_option (get t k) (** {1 Common set modules} *) diff --git a/analysis/reanalyze/src/AnnotationStore.ml b/analysis/reanalyze/src/AnnotationStore.ml index 7987c4fb24c..f9925a65a0a 100644 --- a/analysis/reanalyze/src/AnnotationStore.ml +++ b/analysis/reanalyze/src/AnnotationStore.ml @@ -17,17 +17,16 @@ let is_annotated_dead t pos = | Frozen ann -> FileAnnotations.is_annotated_dead ann pos | Reactive reactive -> let mb = Reactive.get reactive pos in - ReactiveMaybe.is_some mb - && ReactiveMaybe.unsafe_get mb = FileAnnotations.Dead + Maybe.is_some mb && 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 -> let mb = Reactive.get reactive pos in - ReactiveMaybe.is_some mb + Maybe.is_some mb && - let v = ReactiveMaybe.unsafe_get mb in + let v = Maybe.unsafe_get mb in v = FileAnnotations.Live || v = FileAnnotations.GenType let is_annotated_gentype_or_dead t pos = @@ -35,7 +34,7 @@ let is_annotated_gentype_or_dead t pos = | Frozen ann -> FileAnnotations.is_annotated_gentype_or_dead ann pos | Reactive reactive -> let mb = Reactive.get reactive pos in - ReactiveMaybe.is_some mb + Maybe.is_some mb && - let v = ReactiveMaybe.unsafe_get mb in + let v = Maybe.unsafe_get mb in v = FileAnnotations.Dead || v = FileAnnotations.GenType diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml index fc9a4620f67..5ac798dbc0c 100644 --- a/analysis/reanalyze/src/DeadCommon.ml +++ b/analysis/reanalyze/src/DeadCommon.ml @@ -481,7 +481,7 @@ 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 = ReactiveMaybe.is_some (Reactive.get live pos) in + let is_live pos = Maybe.is_some (Reactive.get live pos) in (* hasRefBelow uses on-demand search through value_refs_from *) let hasRefBelow = @@ -522,7 +522,7 @@ 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 ReactiveMaybe.is_some (Reactive.get roots pos) then + else if Maybe.is_some (Reactive.get roots 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 a8b06da5087..594fb08f236 100644 --- a/analysis/reanalyze/src/DeclarationStore.ml +++ b/analysis/reanalyze/src/DeclarationStore.ml @@ -17,7 +17,7 @@ let of_reactive reactive = Reactive reactive let find_opt t pos = match t with | Frozen decls -> Declarations.find_opt decls pos - | Reactive reactive -> ReactiveMaybe.to_option (Reactive.get reactive pos) + | Reactive reactive -> Maybe.to_option (Reactive.get reactive pos) let fold f t init = match t with diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index 87e3d50a38e..b5cc3b334f4 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -32,8 +32,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) decls_by_file ~key_of:(fun posFrom _targets -> posFrom.Lexing.pos_fname) ~f:(fun posFrom targets decls_mb emit -> - if ReactiveMaybe.is_some decls_mb then - let decls_in_file = ReactiveMaybe.unsafe_get decls_mb in + if Maybe.is_some decls_mb then + let decls_in_file = Maybe.unsafe_get decls_mb in List.iter (fun (decl_pos, decl) -> if pos_in_decl posFrom decl then emit decl_pos targets) @@ -46,8 +46,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) decls_by_file ~key_of:(fun posFrom _targets -> posFrom.Lexing.pos_fname) ~f:(fun posFrom targets decls_mb emit -> - if ReactiveMaybe.is_some decls_mb then - let decls_in_file = ReactiveMaybe.unsafe_get decls_mb in + if Maybe.is_some decls_mb then + let decls_in_file = Maybe.unsafe_get decls_mb in List.iter (fun (decl_pos, decl) -> if pos_in_decl posFrom decl then emit decl_pos targets) @@ -62,7 +62,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~key_of:(fun pos _decl -> pos) ~f:(fun pos _decl refs_mb emit -> let refs = - if ReactiveMaybe.is_some refs_mb then ReactiveMaybe.unsafe_get refs_mb + if Maybe.is_some refs_mb then Maybe.unsafe_get refs_mb else PosSet.empty in emit pos refs) @@ -74,7 +74,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~key_of:(fun pos _decl -> pos) ~f:(fun pos _decl refs_mb emit -> let refs = - if ReactiveMaybe.is_some refs_mb then ReactiveMaybe.unsafe_get refs_mb + if Maybe.is_some refs_mb then Maybe.unsafe_get refs_mb else PosSet.empty in emit pos refs) @@ -86,8 +86,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~key_of:(fun pos _value_targets -> pos) ~f:(fun pos value_targets type_targets_mb emit -> let type_targets = - if ReactiveMaybe.is_some type_targets_mb then - ReactiveMaybe.unsafe_get type_targets_mb + if Maybe.is_some type_targets_mb then Maybe.unsafe_get type_targets_mb else PosSet.empty in emit pos (value_targets, type_targets)) diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index 0a612b8a430..243f1fc1c07 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -48,8 +48,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) exception_decls ~key_of:(fun path _loc_from -> path) ~f:(fun _path loc_from loc_to_mb emit -> - if ReactiveMaybe.is_some loc_to_mb then - let loc_to = ReactiveMaybe.unsafe_get loc_to_mb in + if Maybe.is_some loc_to_mb then + let loc_to = Maybe.unsafe_get loc_to_mb in (* Add value reference: pos_to -> pos_from (refs_to direction) *) emit loc_to.Location.loc_start (PosSet.singleton loc_from.Location.loc_start)) diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 247e037607e..1c1dd4dfc17 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -61,7 +61,7 @@ let create ~(merged : ReactiveMerge.t) : t = decls ~key_of:(fun posFrom _targets -> posFrom) ~f:(fun _posFrom targets decl_mb emit -> - if not (ReactiveMaybe.is_some decl_mb) then + if not (Maybe.is_some decl_mb) then (* posFrom is NOT a decl position, targets are externally referenced *) PosSet.elements targets |> List.iter (fun posTo -> emit posTo ())) ~merge:(fun () () -> ()) @@ -73,7 +73,7 @@ let create ~(merged : ReactiveMerge.t) : t = decls ~key_of:(fun posFrom _targets -> posFrom) ~f:(fun _posFrom targets decl_mb emit -> - if not (ReactiveMaybe.is_some decl_mb) then + if not (Maybe.is_some decl_mb) then (* posFrom is NOT a decl position, targets are externally referenced *) PosSet.elements targets |> List.iter (fun posTo -> emit posTo ())) ~merge:(fun () () -> ()) @@ -92,8 +92,8 @@ let create ~(merged : ReactiveMerge.t) : t = Reactive.Join.create ~name:"liveness.annotated_roots" decls annotations ~key_of:(fun pos _decl -> pos) ~f:(fun pos _decl ann_mb emit -> - if ReactiveMaybe.is_some ann_mb then - match ReactiveMaybe.unsafe_get ann_mb with + if Maybe.is_some ann_mb then + match Maybe.unsafe_get ann_mb with | FileAnnotations.Live | FileAnnotations.GenType -> emit pos () | _ -> ()) ~merge:(fun () () -> ()) diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index 2bb909a3edb..33be66fef0c 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -58,7 +58,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.Join.create ~name:"solver.dead_decls" decls live ~key_of:(fun pos _decl -> pos) ~f:(fun pos decl live_mb emit -> - if not (ReactiveMaybe.is_some live_mb) then emit pos decl) + if not (Maybe.is_some live_mb) then emit pos decl) () in @@ -67,7 +67,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.Join.create ~name:"solver.live_decls" decls live ~key_of:(fun pos _decl -> pos) ~f:(fun pos decl live_mb emit -> - if ReactiveMaybe.is_some live_mb then emit pos decl) + if Maybe.is_some live_mb then emit pos decl) () in @@ -99,8 +99,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) modules_with_live ~key_of:(fun modName (_loc, _fileName) -> modName) ~f:(fun modName (loc, fileName) live_mb emit -> - if not (ReactiveMaybe.is_some live_mb) then - emit modName (loc, fileName) (* dead: no live decls *)) + if not (Maybe.is_some live_mb) then emit modName (loc, fileName) + (* dead: no live decls *)) () in @@ -124,8 +124,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* shouldReport checks annotations reactively *) let shouldReport (decl : Decl.t) = let ann = Reactive.get annotations decl.pos in - if ReactiveMaybe.is_some ann then - match ReactiveMaybe.unsafe_get ann with + if Maybe.is_some ann then + match Maybe.unsafe_get ann with | FileAnnotations.Live -> false | FileAnnotations.GenType -> false | FileAnnotations.Dead -> false @@ -190,8 +190,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) annotations ~key_of:(fun pos _decl -> pos) ~f:(fun pos decl ann_mb emit -> - if ReactiveMaybe.is_some ann_mb then - match ReactiveMaybe.unsafe_get ann_mb with + if Maybe.is_some ann_mb then + match Maybe.unsafe_get ann_mb with | FileAnnotations.Dead -> emit pos decl | _ -> ()) () @@ -211,7 +211,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) modules_with_reported ~key_of:(fun moduleName (_loc, _fileName) -> moduleName) ~f:(fun moduleName (loc, fileName) has_reported_mb emit -> - if ReactiveMaybe.is_some has_reported_mb then + if Maybe.is_some has_reported_mb then let loc = if loc.Location.loc_ghost then let pos = @@ -253,8 +253,8 @@ let check_module_dead ~(dead_modules : (Name.t, Location.t * string) Reactive.t) if Hashtbl.mem reported_modules moduleName then None else let dm = Reactive.get dead_modules moduleName in - if ReactiveMaybe.is_some dm then ( - let loc, fileName = ReactiveMaybe.unsafe_get dm in + if Maybe.is_some dm then ( + let loc, fileName = Maybe.unsafe_get dm in Hashtbl.replace reported_modules moduleName (); let loc = if loc.Location.loc_ghost then @@ -334,9 +334,8 @@ let iter_live_decls ~(t : t) (f : Decl.t -> unit) : unit = Returns true if pos is not a declaration (matches non-reactive behavior). *) let is_pos_live ~(t : t) (pos : Lexing.position) : bool = let d = Reactive.get t.decls pos in - if not (ReactiveMaybe.is_some d) then true - (* not a declaration, assume live *) - else ReactiveMaybe.is_some (Reactive.get t.live pos) + if not (Maybe.is_some d) then true (* not a declaration, assume live *) + else Maybe.is_some (Reactive.get t.live pos) (** Stats *) let stats ~(t : t) : int * int = diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 7baf2e6bc1f..064e01f0917 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -105,8 +105,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) decl_by_path ~key_of:(fun _pos (_, intf_path1, _) -> intf_path1) ~f:(fun _pos (info, _intf_path1, _intf_path2) intf_decls_mb emit -> - if ReactiveMaybe.is_some intf_decls_mb then - match ReactiveMaybe.unsafe_get intf_decls_mb with + if Maybe.is_some intf_decls_mb then + match Maybe.unsafe_get intf_decls_mb with | intf_info :: _ -> (* Found at path1: posTo=impl, posFrom=intf *) emit info.pos (PosSet.singleton intf_info.pos); @@ -124,9 +124,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) ~key_of:(fun _pos (_, intf_path1, _) -> intf_path1) ~f:(fun pos (info, _intf_path1, intf_path2) intf_decls_mb emit -> let found = - ReactiveMaybe.is_some intf_decls_mb + Maybe.is_some intf_decls_mb && - match ReactiveMaybe.unsafe_get intf_decls_mb with + match Maybe.unsafe_get intf_decls_mb with | _ :: _ -> true | [] -> false in @@ -139,8 +139,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) impl_needing_path2 decl_by_path ~key_of:(fun _pos (_, intf_path2) -> intf_path2) ~f:(fun _pos (info, _) intf_decls_mb emit -> - if ReactiveMaybe.is_some intf_decls_mb then - match ReactiveMaybe.unsafe_get intf_decls_mb with + if Maybe.is_some intf_decls_mb then + match Maybe.unsafe_get intf_decls_mb with | intf_info :: _ -> (* posTo=impl, posFrom=intf *) emit info.pos (PosSet.singleton intf_info.pos); @@ -176,8 +176,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) decl_by_path ~key_of:(fun _pos (_, impl_path) -> impl_path) ~f:(fun _pos (intf_info, _) impl_decls_mb emit -> - if ReactiveMaybe.is_some impl_decls_mb then - match ReactiveMaybe.unsafe_get impl_decls_mb with + if Maybe.is_some impl_decls_mb then + match 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: diff --git a/analysis/reanalyze/src/Reanalyze.ml b/analysis/reanalyze/src/Reanalyze.ml index ea4d6d046c9..6aa74de4df4 100644 --- a/analysis/reanalyze/src/Reanalyze.ml +++ b/analysis/reanalyze/src/Reanalyze.ml @@ -340,8 +340,7 @@ 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 = - ReactiveMaybe.to_option - (Reactive.get merged.ReactiveMerge.decls pos) + Maybe.to_option (Reactive.get merged.ReactiveMerge.decls pos) in let optional_args_state = CrossFileItemsStore.compute_optional_args_state From 51a11f7a4b5a3134f311e4df0de737c0003d6f16 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 07:45:32 +0100 Subject: [PATCH 23/54] analysis/reactive: fix build after allocator refactors --- analysis/reactive/src/Allocator.ml | 24 +++++++----- analysis/reactive/src/Allocator.mli | 17 +++++---- analysis/reactive/src/ReactiveMap.ml | 2 +- analysis/reactive/src/ReactiveTable.ml | 41 ++++++++++---------- analysis/reactive/src/ReactiveWave.ml | 44 +++++++++++----------- analysis/reanalyze/src/ReactiveLiveness.ml | 3 +- 6 files changed, 69 insertions(+), 62 deletions(-) diff --git a/analysis/reactive/src/Allocator.ml b/analysis/reactive/src/Allocator.ml index a0f56a794fa..3bc7a6a3662 100644 --- a/analysis/reactive/src/Allocator.ml +++ b/analysis/reactive/src/Allocator.ml @@ -27,24 +27,30 @@ let to_offheap x = unsafe_to_offheap x module Block = struct - type t = int + type 'a t = int - external create_unsafe : int -> t = "caml_reactive_allocator_create" + external create_unsafe : int -> 'a t = "caml_reactive_allocator_create" [@@noalloc] - external destroy : t -> unit = "caml_reactive_allocator_destroy" [@@noalloc] - external capacity : t -> int = "caml_reactive_allocator_capacity" [@@noalloc] - external resize_unsafe : t -> int -> unit = "caml_reactive_allocator_resize" + external destroy : 'a t -> unit = "caml_reactive_allocator_destroy" [@@noalloc] - external unsafe_get : t -> int -> 'a offheap = "caml_reactive_allocator_get" + external capacity : 'a t -> int = "caml_reactive_allocator_capacity" [@@noalloc] - external unsafe_set : t -> int -> 'a offheap -> unit + external resize_unsafe : 'a t -> int -> unit + = "caml_reactive_allocator_resize" + [@@noalloc] + + external unsafe_get : 'a t -> int -> 'a offheap + = "caml_reactive_allocator_get" + [@@noalloc] + + external unsafe_set : 'a t -> int -> 'a offheap -> unit = "caml_reactive_allocator_set" [@@noalloc] - external blit_unsafe : t -> int -> t -> int -> int -> unit + external blit_unsafe : 'a t -> int -> 'a t -> int -> int -> unit = "caml_reactive_allocator_blit" [@@noalloc] @@ -78,7 +84,7 @@ module Block = struct end module Block2 = struct - type ('a, 'x, 'y) t = Block.t + type ('a, 'x, 'y) t = 'a Block.t let header_slots = 2 diff --git a/analysis/reactive/src/Allocator.mli b/analysis/reactive/src/Allocator.mli index fd0493a78c4..a9a6c1183ab 100644 --- a/analysis/reactive/src/Allocator.mli +++ b/analysis/reactive/src/Allocator.mli @@ -39,28 +39,29 @@ val unsafe_from_offheap : 'a offheap -> 'a (** Unsafely recover a regular OCaml value from an off-heap-marked value. *) module Block : sig - type t + type 'a t - val create : capacity:int -> t + val create : capacity:int -> 'a t (** Allocate an off-heap block of raw OCaml value slots. *) - val destroy : t -> unit + val destroy : 'a t -> unit (** Release the block storage. The handle must not be used afterwards. *) - val capacity : t -> int + val capacity : 'a t -> int (** Current block size, in slots. *) - val resize : t -> capacity:int -> unit + val resize : 'a t -> capacity:int -> unit (** Resize the block, preserving the prefix up to the new capacity. *) - val get : t -> int -> 'a offheap + val get : 'a t -> int -> 'a offheap (** Read a slot. The caller is responsible for keeping pointed-to values alive and out of the minor heap while stored off-heap. *) - val set : t -> int -> 'a offheap -> unit + val set : 'a t -> int -> 'a offheap -> unit (** Write a slot. *) - val blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit + 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 diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/ReactiveMap.ml index a85e58fb8da..bf0ace58418 100644 --- a/analysis/reactive/src/ReactiveMap.ml +++ b/analysis/reactive/src/ReactiveMap.ml @@ -1,6 +1,6 @@ type ('k, 'v) t = { keys: ('k, int, int) Allocator.Block2.t; - vals: Allocator.Block.t; + vals: 'v Allocator.Block.t; } let initial_capacity = 8 diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml index 83b7494f9b4..64738bb86d3 100644 --- a/analysis/reactive/src/ReactiveTable.ml +++ b/analysis/reactive/src/ReactiveTable.ml @@ -1,24 +1,24 @@ -type 'a t = Allocator.Block.t +type 'a t = Obj.t Allocator.Block.t let length_slot = 0 let data_offset = 1 -let length t : int = - Allocator.unsafe_from_offheap (Allocator.Block.get t length_slot) +let length (t : 'a t) : int = Obj.magic (Allocator.Block.get t length_slot) -let capacity t = Allocator.Block.capacity t - data_offset +let capacity (t : 'a t) = Allocator.Block.capacity t - data_offset -let create ~initial_capacity = +let create ~initial_capacity : 'a t = if initial_capacity < 0 then invalid_arg "ReactiveTable.create"; let t = Allocator.Block.create ~capacity:(initial_capacity + data_offset) in - Allocator.Block.set t length_slot (Allocator.int_to_offheap 0); + Allocator.Block.set t length_slot (Obj.magic (Allocator.int_to_offheap 0)); t let destroy = Allocator.Block.destroy -let clear t = Allocator.Block.set t length_slot (Allocator.int_to_offheap 0) +let clear (t : 'a t) = + Allocator.Block.set t length_slot (Obj.magic (Allocator.int_to_offheap 0)) -let ensure_capacity t needed = +let ensure_capacity (t : 'a t) needed = let old_capacity = capacity t in if needed > old_capacity then ( let new_capacity = ref (max 1 old_capacity) in @@ -27,28 +27,31 @@ let ensure_capacity t needed = done; Allocator.Block.resize t ~capacity:(!new_capacity + data_offset)) -let get t index = +let get (t : 'a t) index = let len = length t in if index < 0 || index >= len then invalid_arg "ReactiveTable.get"; - Allocator.Block.get t (index + data_offset) + Obj.magic (Allocator.Block.get t (index + data_offset)) -let set t index value = +let set (t : 'a t) index value = let len = length t in if index < 0 || index >= len then invalid_arg "ReactiveTable.set"; - Allocator.Block.set t (index + data_offset) value + Allocator.Block.set t (index + data_offset) (Obj.magic value) -let push t value = +let push (t : 'a t) value = let len = length t in let next_len = len + 1 in ensure_capacity t next_len; - Allocator.Block.set t (len + data_offset) value; - Allocator.Block.set t length_slot (Allocator.int_to_offheap next_len) + Allocator.Block.set t (len + data_offset) (Obj.magic value); + Allocator.Block.set t length_slot + (Obj.magic (Allocator.int_to_offheap next_len)) -let pop t = +let pop (t : 'a t) = let len = length t in if len = 0 then invalid_arg "ReactiveTable.pop"; - let last = Allocator.Block.get t (len - 1 + data_offset) in - Allocator.Block.set t length_slot (Allocator.int_to_offheap (len - 1)); + let last = Obj.magic (Allocator.Block.get t (len - 1 + data_offset)) in + Allocator.Block.set t length_slot + (Obj.magic (Allocator.int_to_offheap (len - 1))); last -let shrink_to_fit t = Allocator.Block.resize t ~capacity:(length t + data_offset) +let shrink_to_fit (t : 'a t) = + Allocator.Block.resize t ~capacity:(length t + data_offset) diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index cecadffcc7f..581cd63c1c1 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -1,62 +1,60 @@ -type ('k, 'v) t = Allocator.Block.t +type ('k, 'v) t = (Obj.t, int, int) Allocator.Block2.t -let length_slot = 0 -let data_offset = 1 let entry_width = 2 -let length t : int = - Allocator.unsafe_from_offheap (Allocator.Block.get t length_slot) +let length (t : ('k, 'v) t) : int = Allocator.Block2.get0 t -let set_length t len = - Allocator.Block.set t length_slot (Allocator.int_to_offheap len) +let set_length (t : ('k, 'v) t) len = Allocator.Block2.set0 t len -let create ?(max_entries = 16) () = +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.Block.create ~capacity:(data_offset + (max_entries * entry_width)) + Allocator.Block2.create ~capacity:(max_entries * entry_width) ~x0:0 ~y0:0 in set_length t 0; t -let clear t = set_length t 0 +let clear (t : ('k, 'v) t) = set_length t 0 -let destroy t = Allocator.Block.destroy t +let destroy (t : ('k, 'v) t) = Allocator.Block2.destroy t -let ensure_capacity t needed = - let current = (Allocator.Block.capacity t - data_offset) / entry_width in +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.Block.resize t ~capacity:(data_offset + (!next * entry_width))) + Allocator.Block2.resize t ~capacity:(!next * entry_width)) let push (type k v) (t : (k, v) t) (k : k Allocator.offheap) (v : v Allocator.offheap) = let len = length t in ensure_capacity t (len + 1); - let key_slot = data_offset + (len * entry_width) in - Allocator.Block.set t key_slot k; - Allocator.Block.set t (key_slot + 1) v; + 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 Allocator.offheap -> v Allocator.offheap -> unit) = let len = length t in for i = 0 to len - 1 do - let key_slot = data_offset + (i * entry_width) in - f (Allocator.Block.get t key_slot) (Allocator.Block.get t (key_slot + 1)) + 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 Allocator.offheap -> v Allocator.offheap -> unit) (arg : a) = let len = length t in for i = 0 to len - 1 do - let key_slot = data_offset + (i * entry_width) in + let key_slot = i * entry_width in f arg - (Allocator.Block.get t key_slot) - (Allocator.Block.get t (key_slot + 1)) + (Obj.magic (Allocator.Block2.get t key_slot)) + (Obj.magic (Allocator.Block2.get t (key_slot + 1))) done -let count t = length t +let count (t : ('k, 'v) t) = length t diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 1c1dd4dfc17..d2ba76e58e9 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -40,8 +40,7 @@ let create ~(merged : ReactiveMerge.t) : t = Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index ~f:(fun pos (value_targets, type_targets) emit -> let all_targets = PosSet.union value_targets type_targets in - emit pos - (ReactiveOffheapList.unsafe_of_list (PosSet.elements all_targets))) + emit pos (PosSet.elements all_targets)) () in From 131eac0ef600fb536b7c8ff90ce700df42bf8569 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 07:46:33 +0100 Subject: [PATCH 24/54] analysis/reactive: rename offheap list module --- analysis/reactive/src/Maybe.ml | 2 +- analysis/reactive/src/Maybe.mli | 2 +- ...{ReactiveOffheapList.ml => OffheapList.ml} | 0 ...eactiveOffheapList.mli => OffheapList.mli} | 0 analysis/reactive/src/ReactiveFixpoint.ml | 98 +++++++++---------- analysis/reactive/test/AllocTest.ml | 2 +- analysis/reactive/test/TestHelpers.ml | 4 +- 7 files changed, 49 insertions(+), 59 deletions(-) rename analysis/reactive/src/{ReactiveOffheapList.ml => OffheapList.ml} (100%) rename analysis/reactive/src/{ReactiveOffheapList.mli => OffheapList.mli} (100%) diff --git a/analysis/reactive/src/Maybe.ml b/analysis/reactive/src/Maybe.ml index d76471bf2b3..126324fc4f2 100644 --- a/analysis/reactive/src/Maybe.ml +++ b/analysis/reactive/src/Maybe.ml @@ -21,7 +21,7 @@ let[@inline] maybe_int_to_offheap (x : int t) : int t Allocator.offheap = let[@inline] maybe_unit_to_offheap (x : unit t) : unit t Allocator.offheap = Allocator.unsafe_to_offheap x -let[@inline] maybe_offheap_list_to_offheap (x : 'a ReactiveOffheapList.t t) : +let[@inline] maybe_offheap_list_to_offheap (x : 'a OffheapList.t t) : 'a list t Allocator.offheap = Allocator.unsafe_to_offheap x diff --git a/analysis/reactive/src/Maybe.mli b/analysis/reactive/src/Maybe.mli index ba4b92deac7..954e8e43e05 100644 --- a/analysis/reactive/src/Maybe.mli +++ b/analysis/reactive/src/Maybe.mli @@ -28,7 +28,7 @@ val maybe_unit_to_offheap : unit t -> unit t Allocator.offheap (** Safely mark a [unit] maybe value as suitable for off-heap storage. *) val maybe_offheap_list_to_offheap : - 'a ReactiveOffheapList.t t -> 'a list t Allocator.offheap + 'a OffheapList.t t -> 'a list t Allocator.offheap (** Mark a maybe value carrying an already offheap-marked list as suitable for storage in an off-heap container with semantic payload type ['a list]. *) diff --git a/analysis/reactive/src/ReactiveOffheapList.ml b/analysis/reactive/src/OffheapList.ml similarity index 100% rename from analysis/reactive/src/ReactiveOffheapList.ml rename to analysis/reactive/src/OffheapList.ml diff --git a/analysis/reactive/src/ReactiveOffheapList.mli b/analysis/reactive/src/OffheapList.mli similarity index 100% rename from analysis/reactive/src/ReactiveOffheapList.mli rename to analysis/reactive/src/OffheapList.mli diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 302dabe80c3..2a09d441fc8 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -17,7 +17,7 @@ type 'k metrics_state = { type 'k t = { current: 'k ReactiveSet.t; - edge_map: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; + edge_map: ('k, 'k OffheapList.inner) ReactiveMap.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; roots: 'k ReactiveSet.t; output_wave: ('k, unit Maybe.t) ReactiveWave.t; @@ -25,8 +25,8 @@ type 'k t = { deleted_nodes: 'k ReactiveSet.t; rederive_pending: 'k ReactiveSet.t; expansion_seen: 'k ReactiveSet.t; - old_successors_for_changed: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; - new_successors_for_changed: ('k, 'k ReactiveOffheapList.inner) ReactiveMap.t; + old_successors_for_changed: ('k, 'k OffheapList.inner) ReactiveMap.t; + new_successors_for_changed: ('k, 'k OffheapList.inner) ReactiveMap.t; (* Scratch sets for analyze_edge_change / apply_edge_update *) scratch_set_a: 'k ReactiveSet.t; scratch_set_b: 'k ReactiveSet.t; @@ -43,15 +43,12 @@ type 'k t = { (* Standalone version for Invariants (no scratch sets available). Debug-only — allocates temporary Hashtbl. *) let analyze_edge_change_has_new ~old_succs ~new_succs = - if ReactiveOffheapList.is_empty old_succs then - not (ReactiveOffheapList.is_empty new_succs) - else if ReactiveOffheapList.is_empty new_succs then false + if OffheapList.is_empty old_succs then not (OffheapList.is_empty new_succs) + else if OffheapList.is_empty new_succs then false else - let old_set = Hashtbl.create (ReactiveOffheapList.length old_succs) in - ReactiveOffheapList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; - ReactiveOffheapList.exists - (fun tgt -> not (Hashtbl.mem old_set tgt)) - new_succs + let old_set = Hashtbl.create (OffheapList.length old_succs) in + OffheapList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; + OffheapList.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs let[@inline] off_key k = Allocator.unsafe_to_offheap k let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) @@ -84,8 +81,8 @@ let compute_reachable ~visited t = let r = ReactiveMap.find_maybe t.edge_map k in if Maybe.is_some r then ( let succs = Maybe.unsafe_get r in - edge_work := !edge_work + ReactiveOffheapList.length succs; - ReactiveOffheapList.iter_with (bfs_visit_succ visited) frontier succs) + edge_work := !edge_work + OffheapList.length succs; + OffheapList.iter_with (bfs_visit_succ visited) frontier succs) done; (!node_work, !edge_work) @@ -268,14 +265,14 @@ module Invariants = struct in let old_succs = if Maybe.is_some r_old then Maybe.unsafe_get r_old - else ReactiveOffheapList.empty () + else OffheapList.empty () in let r_new = ReactiveMap.find_maybe new_successors_for_changed (off_key src) in let new_succs = if Maybe.is_some r_new then Maybe.unsafe_get r_new - else ReactiveOffheapList.empty () + else OffheapList.empty () in let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs @@ -287,7 +284,7 @@ module Invariants = struct !items) let assert_deleted_nodes_closed ~current ~deleted_nodes - ~(old_successors : 'k -> 'k ReactiveOffheapList.t) = + ~(old_successors : 'k -> 'k OffheapList.t) = if enabled then ReactiveSet.iter_with (fun () k -> @@ -296,7 +293,7 @@ module Invariants = struct (ReactiveSet.mem current (off_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; - ReactiveOffheapList.iter + OffheapList.iter (fun succ -> if ReactiveSet.mem current (off_key succ) then assert_ @@ -493,35 +490,33 @@ let remove_pred_for_src (t, src) target = remove_pred t ~target ~pred:src let apply_edge_update t ~src ~new_successors = let r = ReactiveMap.find_maybe t.edge_map (off_key src) in let old_successors = - if Maybe.is_some r then Maybe.unsafe_get r else ReactiveOffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () in - if - ReactiveOffheapList.is_empty old_successors - && ReactiveOffheapList.is_empty new_successors + if OffheapList.is_empty old_successors && OffheapList.is_empty new_successors then ReactiveMap.remove t.edge_map (off_key src) - else if ReactiveOffheapList.is_empty old_successors then ( - ReactiveOffheapList.iter_with add_pred_for_src (t, src) new_successors; + else if OffheapList.is_empty old_successors then ( + OffheapList.iter_with add_pred_for_src (t, src) new_successors; ReactiveMap.replace t.edge_map (off_key src) new_successors) - else if ReactiveOffheapList.is_empty new_successors then ( - ReactiveOffheapList.iter_with remove_pred_for_src (t, src) old_successors; + else if OffheapList.is_empty new_successors then ( + OffheapList.iter_with remove_pred_for_src (t, src) old_successors; ReactiveMap.remove t.edge_map (off_key src)) else ( ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; - ReactiveOffheapList.iter + OffheapList.iter (fun k -> ReactiveSet.add t.scratch_set_a (off_key k)) new_successors; - ReactiveOffheapList.iter + OffheapList.iter (fun k -> ReactiveSet.add t.scratch_set_b (off_key k)) old_successors; - ReactiveOffheapList.iter_with + OffheapList.iter_with (fun () target -> if not (ReactiveSet.mem t.scratch_set_a (off_key target)) then remove_pred t ~target ~pred:src) () old_successors; - ReactiveOffheapList.iter_with + OffheapList.iter_with (fun () target -> if not (ReactiveSet.mem t.scratch_set_b (off_key target)) then add_pred t ~target ~pred:src) @@ -537,7 +532,7 @@ let initialize t ~roots ~edges = ReactiveWave.iter edges (fun k successors -> apply_edge_update t ~src:(Allocator.unsafe_from_offheap k) - ~new_successors:(ReactiveOffheapList.unsafe_of_offheap_list successors)); + ~new_successors:(OffheapList.unsafe_of_offheap_list successors)); recompute_current t let is_supported t k = @@ -548,8 +543,7 @@ let old_successors t k = if Maybe.is_some r then Maybe.unsafe_get r else let r2 = ReactiveMap.find_maybe t.edge_map (off_key k) in - if Maybe.is_some r2 then Maybe.unsafe_get r2 - else ReactiveOffheapList.empty () + if Maybe.is_some r2 then Maybe.unsafe_get r2 else OffheapList.empty () let mark_deleted t k = if @@ -599,38 +593,35 @@ let mark_deleted_if_absent (t, set) k = let not_in_set set k = not (ReactiveSet.mem set (off_key k)) let mark_deleted_unless_in_set t set xs = - ReactiveOffheapList.iter_with mark_deleted_if_absent (t, set) xs + OffheapList.iter_with mark_deleted_if_absent (t, set) xs -let exists_not_in_set set xs = ReactiveOffheapList.exists_with not_in_set set xs +let exists_not_in_set set xs = OffheapList.exists_with not_in_set set xs let scan_edge_entry t src mv = let r = ReactiveMap.find_maybe t.edge_map (off_key src) in let old_succs = - if Maybe.is_some r then Maybe.unsafe_get r else ReactiveOffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () in let new_succs = - if Maybe.is_some mv then - ReactiveOffheapList.unsafe_of_list (Maybe.unsafe_get mv) - else ReactiveOffheapList.empty () + if Maybe.is_some mv then OffheapList.unsafe_of_list (Maybe.unsafe_get mv) + else OffheapList.empty () in ReactiveMap.replace t.old_successors_for_changed (off_key src) old_succs; ReactiveMap.replace t.new_successors_for_changed (off_key src) new_succs; enqueue t.edge_change_queue src; let src_is_live = ReactiveSet.mem t.current (off_key src) in match (old_succs, new_succs) with - | _ - when ReactiveOffheapList.is_empty old_succs - && ReactiveOffheapList.is_empty new_succs -> + | _ when OffheapList.is_empty old_succs && OffheapList.is_empty new_succs -> () - | _ when ReactiveOffheapList.is_empty old_succs -> + | _ when OffheapList.is_empty old_succs -> ReactiveSet.add t.edge_has_new (off_key src) - | _ when ReactiveOffheapList.is_empty new_succs -> - if src_is_live then ReactiveOffheapList.iter_with mark_deleted t old_succs + | _ when OffheapList.is_empty new_succs -> + if src_is_live then OffheapList.iter_with mark_deleted t old_succs | _ -> ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; - ReactiveOffheapList.iter_with set_add_k t.scratch_set_a new_succs; - ReactiveOffheapList.iter_with set_add_k t.scratch_set_b old_succs; + OffheapList.iter_with set_add_k t.scratch_set_a new_succs; + OffheapList.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 ReactiveSet.add t.edge_has_new (off_key src) @@ -699,8 +690,8 @@ let apply_list t ~roots ~edges = if Metrics.enabled then ( m.delete_queue_pops <- m.delete_queue_pops + 1; m.delete_edges_scanned <- - m.delete_edges_scanned + ReactiveOffheapList.length succs); - ReactiveOffheapList.iter_with mark_deleted t succs + m.delete_edges_scanned + OffheapList.length succs); + OffheapList.iter_with mark_deleted t succs done; if Invariants.enabled then Invariants.assert_deleted_nodes_closed ~current:t.current @@ -719,8 +710,7 @@ let apply_list t ~roots ~edges = let src = ReactiveFifo.pop t.edge_change_queue in let r = ReactiveMap.find_maybe t.new_successors_for_changed src in let new_succs = - if Maybe.is_some r then Maybe.unsafe_get r - else ReactiveOffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () in apply_edge_update t ~src:(Allocator.unsafe_from_offheap src) @@ -762,8 +752,8 @@ let apply_list t ~roots ~edges = let succs = Maybe.unsafe_get r in if Metrics.enabled then m.rederive_edges_scanned <- - m.rederive_edges_scanned + ReactiveOffheapList.length succs; - ReactiveOffheapList.iter_with enqueue_rederive_if_needed t succs)) + m.rederive_edges_scanned + OffheapList.length succs; + OffheapList.iter_with enqueue_rederive_if_needed t succs)) done; if Invariants.enabled then Invariants.assert_no_supported_deleted_left ~deleted_nodes:t.deleted_nodes @@ -794,8 +784,8 @@ let apply_list t ~roots ~edges = let succs = Maybe.unsafe_get r in if Metrics.enabled then m.expansion_edges_scanned <- - m.expansion_edges_scanned + ReactiveOffheapList.length succs; - ReactiveOffheapList.iter_with add_live t succs) + m.expansion_edges_scanned + OffheapList.length succs; + OffheapList.iter_with add_live t succs) done; ReactiveSet.iter_with (fun t k -> emit_removal t (Allocator.unsafe_from_offheap k) ()) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index f2b99759ca5..6cd1bbe9997 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -341,7 +341,7 @@ 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_offheap = Array.map ReactiveOffheapList.of_list edge_values in + let edge_values_offheap = Array.map OffheapList.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 diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index c9cf9aa9a55..9ccb3f7950e 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -29,7 +29,7 @@ let emit_edge_set emit k vs = ReactiveWave.push w (Allocator.unsafe_to_offheap k) (Maybe.maybe_offheap_list_to_offheap - (Maybe.some (ReactiveOffheapList.unsafe_of_list vs))); + (Maybe.some (OffheapList.unsafe_of_list vs))); emit w (** Emit a single remove entry *) @@ -78,7 +78,7 @@ let emit_edge_batch emit entries = ReactiveWave.push w (Allocator.unsafe_to_offheap k) (Maybe.maybe_offheap_list_to_offheap - (Maybe.some (ReactiveOffheapList.unsafe_of_list vs))) + (Maybe.some (OffheapList.unsafe_of_list vs))) | None -> ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap) entries; From bb64e795d8c34df6f24521378a28edb449efdab0 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 07:56:02 +0100 Subject: [PATCH 25/54] analysis/reactive: extract offheap boundary type --- analysis/reactive/src/Allocator.ml | 26 ++--- analysis/reactive/src/Allocator.mli | 38 ++----- analysis/reactive/src/Maybe.ml | 14 +-- analysis/reactive/src/Maybe.mli | 9 +- analysis/reactive/src/Offheap.ml | 13 +++ analysis/reactive/src/Offheap.mli | 25 +++++ analysis/reactive/src/OffheapList.ml | 11 +- analysis/reactive/src/OffheapList.mli | 4 +- analysis/reactive/src/Reactive.ml | 20 ++-- analysis/reactive/src/ReactiveFifo.ml | 2 +- analysis/reactive/src/ReactiveFifo.mli | 4 +- .../reactive/src/ReactiveFileCollection.ml | 12 +-- analysis/reactive/src/ReactiveFixpoint.ml | 58 +++++----- analysis/reactive/src/ReactiveFlatMap.ml | 36 +++---- analysis/reactive/src/ReactiveFlatMap.mli | 5 +- analysis/reactive/src/ReactiveJoin.ml | 71 ++++++------- analysis/reactive/src/ReactiveJoin.mli | 8 +- analysis/reactive/src/ReactiveMap.ml | 29 +++-- analysis/reactive/src/ReactiveMap.mli | 17 ++- analysis/reactive/src/ReactiveSet.ml | 21 ++-- analysis/reactive/src/ReactiveSet.mli | 8 +- analysis/reactive/src/ReactiveTable.ml | 10 +- analysis/reactive/src/ReactiveTable.mli | 8 +- analysis/reactive/src/ReactiveUnion.ml | 100 ++++++++---------- analysis/reactive/src/ReactiveUnion.mli | 6 +- analysis/reactive/src/ReactiveWave.ml | 8 +- analysis/reactive/src/ReactiveWave.mli | 12 +-- analysis/reactive/test/AllocTest.ml | 9 +- analysis/reactive/test/GlitchFreeTest.ml | 4 +- analysis/reactive/test/TableTest.ml | 18 ++-- analysis/reactive/test/TestHelpers.ml | 26 ++--- 31 files changed, 292 insertions(+), 340 deletions(-) create mode 100644 analysis/reactive/src/Offheap.ml create mode 100644 analysis/reactive/src/Offheap.mli diff --git a/analysis/reactive/src/Allocator.ml b/analysis/reactive/src/Allocator.ml index 3bc7a6a3662..2353d9704e9 100644 --- a/analysis/reactive/src/Allocator.ml +++ b/analysis/reactive/src/Allocator.ml @@ -1,5 +1,3 @@ -type 'a offheap = 'a - external slot_size_bytes_unsafe : unit -> int = "caml_reactive_allocator_slot_size_bytes" [@@noalloc] @@ -17,14 +15,6 @@ external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" let check_non_negative name n = if n < 0 then invalid_arg name let slot_size_bytes = slot_size_bytes_unsafe () -let unsafe_to_offheap x = x -let unsafe_from_offheap x = x -let int_to_offheap x = unsafe_to_offheap x -let unit_to_offheap x = unsafe_to_offheap x - -let to_offheap x = - if is_in_minor_heap x then invalid_arg "Allocator.to_offheap"; - unsafe_to_offheap x module Block = struct type 'a t = int @@ -42,11 +32,11 @@ module Block = struct = "caml_reactive_allocator_resize" [@@noalloc] - external unsafe_get : 'a t -> int -> 'a offheap + external unsafe_get : 'a t -> int -> 'a Offheap.t = "caml_reactive_allocator_get" [@@noalloc] - external unsafe_set : 'a t -> int -> 'a offheap -> unit + external unsafe_set : 'a t -> int -> 'a Offheap.t -> unit = "caml_reactive_allocator_set" [@@noalloc] @@ -90,17 +80,17 @@ module Block2 = struct let create ~capacity ~x0 ~y0 = let t = Block.create ~capacity:(capacity + header_slots) in - Block.set t 0 (unsafe_to_offheap x0); - Block.set t 1 (unsafe_to_offheap y0); + Block.set t 0 (Offheap.unsafe_of_value x0); + Block.set t 1 (Offheap.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 = unsafe_from_offheap (Block.get t 0) - let set0 t x = Block.set t 0 (unsafe_to_offheap x) - let get1 t = unsafe_from_offheap (Block.get t 1) - let set1 t y = Block.set t 1 (unsafe_to_offheap y) + let get0 t = Offheap.unsafe_to_value (Block.get t 0) + let set0 t x = Block.set t 0 (Offheap.unsafe_of_value x) + let get1 t = Offheap.unsafe_to_value (Block.get t 1) + let set1 t y = Block.set t 1 (Offheap.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 diff --git a/analysis/reactive/src/Allocator.mli b/analysis/reactive/src/Allocator.mli index a9a6c1183ab..1481be2c773 100644 --- a/analysis/reactive/src/Allocator.mli +++ b/analysis/reactive/src/Allocator.mli @@ -11,32 +11,8 @@ - is not in the minor heap, and - remains reachable through ordinary OCaml roots elsewhere. - Immediates such as [int] are always safe to store. *) - -type 'a offheap -(** A value intended to be stored in off-heap structures. - - This type does not prove safety. It marks values that are crossing the - off-heap boundary so call sites can be audited explicitly. *) - -val unsafe_to_offheap : 'a -> 'a offheap -(** Unsafely mark a value as suitable for off-heap storage. The caller must - ensure the allocator invariants hold. *) - -val to_offheap : 'a -> 'a offheap -(** Safely mark a value as suitable for off-heap storage. - - Raises [Invalid_argument] if the value is currently in the minor heap. - Immediates are accepted. *) - -val int_to_offheap : int -> int offheap -(** Safely mark an [int] as suitable for off-heap storage. *) - -val unit_to_offheap : unit -> unit offheap -(** Safely mark [()] as suitable for off-heap storage. *) - -val unsafe_from_offheap : 'a offheap -> 'a -(** Unsafely recover a regular OCaml value from an off-heap-marked value. *) + Immediates such as [int] are always safe to store. Use {!Offheap} to mark + values that cross into off-heap containers. *) module Block : sig type 'a t @@ -53,11 +29,11 @@ module Block : sig val resize : 'a t -> capacity:int -> unit (** Resize the block, preserving the prefix up to the new capacity. *) - val get : 'a t -> int -> 'a offheap + val get : 'a t -> int -> 'a Offheap.t (** Read a slot. The caller is responsible for keeping pointed-to values alive and out of the minor heap while stored off-heap. *) - val set : 'a t -> int -> 'a offheap -> unit + val set : 'a t -> int -> 'a Offheap.t -> unit (** Write a slot. *) val blit : @@ -87,10 +63,10 @@ module Block2 : sig val get1 : ('a, 'x, 'y) t -> 'y val set1 : ('a, 'x, 'y) t -> 'y -> unit - val get : ('a, 'x, 'y) t -> int -> 'a offheap + val get : ('a, 'x, 'y) t -> int -> 'a Offheap.t (** Read a data slot. *) - val set : ('a, 'x, 'y) t -> int -> 'a offheap -> unit + val set : ('a, 'x, 'y) t -> int -> 'a Offheap.t -> unit (** Write a data slot. *) val blit : @@ -121,4 +97,4 @@ val reset : unit -> unit 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 off-heap storage - invariant in tests and debug code, and by [to_offheap]. *) + invariant in tests and debug code. *) diff --git a/analysis/reactive/src/Maybe.ml b/analysis/reactive/src/Maybe.ml index 126324fc4f2..dc4c3daf506 100644 --- a/analysis/reactive/src/Maybe.ml +++ b/analysis/reactive/src/Maybe.ml @@ -10,20 +10,20 @@ let sentinel_words = 257 let sentinel : Obj.t = Obj.repr (Array.make sentinel_words 0) let none = sentinel -let none_offheap = Allocator.to_offheap none +let none_offheap = Offheap.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] maybe_int_to_offheap (x : int t) : int t Allocator.offheap = - Allocator.unsafe_to_offheap x +let[@inline] maybe_int_to_offheap (x : int t) : int t Offheap.t = + Offheap.unsafe_of_value x -let[@inline] maybe_unit_to_offheap (x : unit t) : unit t Allocator.offheap = - Allocator.unsafe_to_offheap x +let[@inline] maybe_unit_to_offheap (x : unit t) : unit t Offheap.t = + Offheap.unsafe_of_value x let[@inline] maybe_offheap_list_to_offheap (x : 'a OffheapList.t t) : - 'a list t Allocator.offheap = - Allocator.unsafe_to_offheap x + 'a list t Offheap.t = + Offheap.unsafe_of_value x let[@inline] to_option (x : 'a t) : 'a option = if x != sentinel then Some (Obj.obj x) else None diff --git a/analysis/reactive/src/Maybe.mli b/analysis/reactive/src/Maybe.mli index 954e8e43e05..b270f863d3d 100644 --- a/analysis/reactive/src/Maybe.mli +++ b/analysis/reactive/src/Maybe.mli @@ -12,7 +12,7 @@ type 'a t val none : 'a t (** Unique sentinel representing the absent case. *) -val none_offheap : 'a t Allocator.offheap +val none_offheap : 'a t Offheap.t (** Off-heap-marked form of [none]. Safe because the sentinel is allocated outside the minor heap and kept reachable for the lifetime of the process. *) @@ -21,14 +21,13 @@ val is_none : 'a t -> bool val is_some : 'a t -> bool val unsafe_get : 'a t -> 'a -val maybe_int_to_offheap : int t -> int t Allocator.offheap +val maybe_int_to_offheap : int t -> int t Offheap.t (** Safely mark an [int] maybe value as suitable for off-heap storage. *) -val maybe_unit_to_offheap : unit t -> unit t Allocator.offheap +val maybe_unit_to_offheap : unit t -> unit t Offheap.t (** Safely mark a [unit] maybe value as suitable for off-heap storage. *) -val maybe_offheap_list_to_offheap : - 'a OffheapList.t t -> 'a list t Allocator.offheap +val maybe_offheap_list_to_offheap : 'a OffheapList.t t -> 'a list t Offheap.t (** Mark a maybe value carrying an already offheap-marked list as suitable for storage in an off-heap container with semantic payload type ['a list]. *) diff --git a/analysis/reactive/src/Offheap.ml b/analysis/reactive/src/Offheap.ml new file mode 100644 index 00000000000..18500ddf5ef --- /dev/null +++ b/analysis/reactive/src/Offheap.ml @@ -0,0 +1,13 @@ +type 'a t = 'a + +external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" +[@@noalloc] + +let unsafe_of_value x = x +let unsafe_to_value x = x +let int x = unsafe_of_value x +let unit x = unsafe_of_value x + +let of_value x = + if is_in_minor_heap x then invalid_arg "Offheap.of_value"; + unsafe_of_value x diff --git a/analysis/reactive/src/Offheap.mli b/analysis/reactive/src/Offheap.mli new file mode 100644 index 00000000000..0f1096bc4c7 --- /dev/null +++ b/analysis/reactive/src/Offheap.mli @@ -0,0 +1,25 @@ +(** Values marked for storage in off-heap containers. + + This type does not prove safety. It marks values that are crossing the + off-heap boundary so call sites can be audited explicitly. *) + +type 'a t + +val unsafe_of_value : 'a -> 'a t +(** Unsafely mark a value as suitable for off-heap storage. The caller must + ensure the off-heap invariants hold. *) + +val of_value : 'a -> 'a t +(** Safely mark a value as suitable for off-heap 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 off-heap storage. *) + +val unit : unit -> unit t +(** Safely mark [()] as suitable for off-heap storage. *) + +val unsafe_to_value : 'a t -> 'a +(** Unsafely recover a regular OCaml value from an off-heap-marked value. *) diff --git a/analysis/reactive/src/OffheapList.ml b/analysis/reactive/src/OffheapList.ml index 7d9b8c55553..b4a2a8cf1d1 100644 --- a/analysis/reactive/src/OffheapList.ml +++ b/analysis/reactive/src/OffheapList.ml @@ -1,11 +1,10 @@ type 'a inner = 'a list -type 'a t = 'a inner Allocator.offheap +type 'a t = 'a inner Offheap.t -let unsafe_of_list = Allocator.unsafe_to_offheap -let of_list = Allocator.to_offheap -let list_of = Allocator.unsafe_from_offheap -let unsafe_of_offheap_list xs = - unsafe_of_list (Allocator.unsafe_from_offheap xs) +let unsafe_of_list = Offheap.unsafe_of_value +let of_list = Offheap.of_value +let list_of = Offheap.unsafe_to_value +let unsafe_of_offheap_list xs = unsafe_of_list (Offheap.unsafe_to_value xs) let empty () : 'a t = unsafe_of_list [] diff --git a/analysis/reactive/src/OffheapList.mli b/analysis/reactive/src/OffheapList.mli index 5ad2426185a..701a28424f6 100644 --- a/analysis/reactive/src/OffheapList.mli +++ b/analysis/reactive/src/OffheapList.mli @@ -4,7 +4,7 @@ boundary explicit when such a list is stored in an off-heap container. *) type 'a inner -type 'a t = 'a inner Allocator.offheap +type 'a t = 'a inner Offheap.t val unsafe_of_list : 'a list -> 'a t (** Reinterpret a list as offheap-marked without checking. *) @@ -13,7 +13,7 @@ val of_list : 'a list -> 'a t (** Checked version of [unsafe_of_list]. Raises if the list is still in the minor heap. *) -val unsafe_of_offheap_list : 'a list Allocator.offheap -> 'a t +val unsafe_of_offheap_list : 'a list Offheap.t -> 'a t (** Reinterpret an already offheap-marked list as an offheap-list value. *) val empty : unit -> 'a t diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index a4968e83909..2a2433aef99 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -472,9 +472,7 @@ let level t = t.level let name t = t.name let unsafe_wave_push wave k v = - ReactiveWave.push wave - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap v) + ReactiveWave.push wave (Offheap.unsafe_of_value k) (Offheap.unsafe_of_value v) (** {1 Source Collection} *) @@ -485,8 +483,8 @@ module Source = struct } let apply_emit (tables : ('k, 'v) tables) k mv = - let k = Allocator.unsafe_from_offheap k in - let mv = Allocator.unsafe_from_offheap mv in + let k = Offheap.unsafe_to_value k in + let mv = Offheap.unsafe_to_value mv in if Maybe.is_some mv then ( let v = Maybe.unsafe_get mv in ReactiveHash.Map.replace tables.tbl k v; @@ -801,8 +799,8 @@ end module Fixpoint = struct let unsafe_wave_map_replace pending k v = ReactiveHash.Map.replace pending - (Allocator.unsafe_from_offheap k) - (Allocator.unsafe_from_offheap v) + (Offheap.unsafe_to_value k) + (Offheap.unsafe_to_value v) let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = @@ -861,8 +859,8 @@ module Fixpoint = struct ReactiveHash.Map.iter_with (fun wave k mv -> ReactiveWave.push wave - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap mv)) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value mv)) edge_wave edge_pending; ReactiveHash.Map.clear root_pending; ReactiveHash.Map.clear edge_pending; @@ -920,8 +918,8 @@ module Fixpoint = struct init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); edges.iter (fun k succs -> ReactiveWave.push init_edges_wave - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap succs)); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value succs)); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; ReactiveWave.destroy init_roots_wave; diff --git a/analysis/reactive/src/ReactiveFifo.ml b/analysis/reactive/src/ReactiveFifo.ml index 613526b5f3b..1d6f3484e74 100644 --- a/analysis/reactive/src/ReactiveFifo.ml +++ b/analysis/reactive/src/ReactiveFifo.ml @@ -3,7 +3,7 @@ - ['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 Allocator.offheap]. + - Data slots: queue elements, stored as ['a Offheap.t]. Head and tail are monotone counters. Physical slot positions are computed from the current capacity via bit masking, so the backing capacity always diff --git a/analysis/reactive/src/ReactiveFifo.mli b/analysis/reactive/src/ReactiveFifo.mli index 7059123a429..0f5880e093f 100644 --- a/analysis/reactive/src/ReactiveFifo.mli +++ b/analysis/reactive/src/ReactiveFifo.mli @@ -12,13 +12,13 @@ val destroy : 'a t -> unit val clear : 'a t -> unit (** Remove all elements while keeping the current storage. *) -val push : 'a t -> 'a Allocator.offheap -> unit +val push : 'a t -> 'a Offheap.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 Allocator.offheap +val pop : 'a t -> 'a Offheap.t (** Remove and return the next element. @raise Invalid_argument if the queue is empty. *) diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index f1c9594b208..6ef2ac061c7 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -42,8 +42,8 @@ let to_collection t : (string, 'v) Reactive.t = t.collection let emit_set t path value = ReactiveWave.clear t.scratch_wave; ReactiveWave.push t.scratch_wave - (Allocator.unsafe_to_offheap path) - (Allocator.unsafe_to_offheap (Maybe.some value)); + (Offheap.unsafe_of_value path) + (Offheap.unsafe_of_value (Maybe.some value)); t.emit t.scratch_wave (** Process a file if changed. Emits delta to subscribers. *) @@ -78,8 +78,8 @@ let process_files_batch t paths = let value = t.internal.process path raw in Hashtbl.replace t.internal.cache path (new_id, value); ReactiveWave.push t.scratch_wave - (Allocator.unsafe_to_offheap path) - (Allocator.unsafe_to_offheap (Maybe.some value)); + (Offheap.unsafe_of_value path) + (Offheap.unsafe_of_value (Maybe.some value)); incr count) paths; if !count > 0 then t.emit t.scratch_wave; @@ -90,7 +90,7 @@ let remove t path = Hashtbl.remove t.internal.cache path; ReactiveWave.clear t.scratch_wave; ReactiveWave.push t.scratch_wave - (Allocator.unsafe_to_offheap path) + (Offheap.unsafe_of_value path) Maybe.none_offheap; t.emit t.scratch_wave @@ -103,7 +103,7 @@ let remove_batch t paths = if Hashtbl.mem t.internal.cache path then ( Hashtbl.remove t.internal.cache path; ReactiveWave.push t.scratch_wave - (Allocator.unsafe_to_offheap path) + (Offheap.unsafe_of_value path) Maybe.none_offheap; incr count)) paths; diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 2a09d441fc8..90ba0806370 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -50,7 +50,7 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = OffheapList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; OffheapList.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs -let[@inline] off_key k = Allocator.unsafe_to_offheap k +let[@inline] off_key k = Offheap.unsafe_of_value k let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) (* Full-reachability BFS into [visited]. Returns (node_work, edge_work). @@ -73,7 +73,7 @@ let compute_reachable ~visited t = let edge_work = ref 0 in ReactiveSet.iter_with (fun (visited, frontier) k -> - bfs_seed_root visited frontier t (Allocator.unsafe_from_offheap k) ()) + bfs_seed_root visited frontier t (Offheap.unsafe_to_value k) ()) (visited, frontier) t.roots; while not (ReactiveFifo.is_empty frontier) do let k = ReactiveFifo.pop frontier in @@ -230,7 +230,7 @@ module Invariants = struct let copy_set_to_hashtbl (s : 'k ReactiveSet.t) = let out = Hashtbl.create (ReactiveSet.cardinal s) in ReactiveSet.iter_with - (fun out k -> Hashtbl.replace out (Allocator.unsafe_from_offheap k) ()) + (fun out k -> Hashtbl.replace out (Offheap.unsafe_to_value k) ()) out s; out @@ -249,7 +249,7 @@ module Invariants = struct let items = ref [] in while not (ReactiveFifo.is_empty edge_change_queue) do let src = - Allocator.unsafe_from_offheap (ReactiveFifo.pop edge_change_queue) + Offheap.unsafe_to_value (ReactiveFifo.pop edge_change_queue) in items := src :: !items; enqueue q_copy src @@ -288,7 +288,7 @@ module Invariants = struct if enabled then ReactiveSet.iter_with (fun () k -> - let k = Allocator.unsafe_from_offheap k in + let k = Offheap.unsafe_to_value k in assert_ (ReactiveSet.mem current (off_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ @@ -307,7 +307,7 @@ module Invariants = struct if enabled then ReactiveSet.iter_with (fun () k -> - let k = Allocator.unsafe_from_offheap k in + let k = Offheap.unsafe_to_value k in if not (ReactiveSet.mem current (off_key k)) then assert_ (not (supported k)) @@ -319,8 +319,7 @@ module Invariants = struct if enabled then ( let expected = Hashtbl.copy pre_current in ReactiveSet.iter_with - (fun expected k -> - Hashtbl.remove expected (Allocator.unsafe_from_offheap k)) + (fun expected k -> Hashtbl.remove expected (Offheap.unsafe_to_value k)) expected deleted_nodes; let current_ht = copy_set_to_hashtbl current in assert_ @@ -333,7 +332,7 @@ module Invariants = struct let expected = Hashtbl.create (ReactiveSet.cardinal deleted_nodes) in ReactiveSet.iter_with (fun expected k -> - let k = Allocator.unsafe_from_offheap k in + let k = Offheap.unsafe_to_value k in if not (ReactiveSet.mem current (off_key k)) then Hashtbl.replace expected k ()) expected deleted_nodes; @@ -360,7 +359,7 @@ module Invariants = struct let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in ReactiveSet.iter_with (fun expected_adds k -> - let k = Allocator.unsafe_from_offheap k in + let k = Offheap.unsafe_to_value k in if not (Hashtbl.mem pre_current k) then Hashtbl.replace expected_adds k ()) expected_adds t.current; @@ -461,7 +460,7 @@ type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t let iter_current t f = ReactiveSet.iter_with - (fun f k -> f (Allocator.unsafe_from_offheap k) ()) + (fun f k -> f (Offheap.unsafe_to_value k) ()) f t.current let get_current t k = @@ -531,7 +530,7 @@ let initialize t ~roots ~edges = ReactiveWave.iter roots (fun k _ -> ReactiveSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> apply_edge_update t - ~src:(Allocator.unsafe_from_offheap k) + ~src:(Offheap.unsafe_to_value k) ~new_successors:(OffheapList.unsafe_of_offheap_list successors)); recompute_current t @@ -566,7 +565,7 @@ let add_live t k = ReactiveSet.add t.current (off_key k); if not (ReactiveSet.mem t.deleted_nodes (off_key k)) then ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k) + (Offheap.unsafe_of_value k) (Maybe.maybe_unit_to_offheap (Maybe.some ())); enqueue_expand t k) @@ -633,7 +632,7 @@ let apply_root_mutation t k mv = let emit_removal t k () = if not (ReactiveSet.mem t.current (off_key k)) then ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k) + (Offheap.unsafe_of_value k) Maybe.none_offheap let rebuild_edge_change_queue t src _succs = @@ -663,9 +662,7 @@ let apply_list t ~roots ~edges = buffer added roots for later expansion *) ReactiveWave.iter_with roots (fun t k mv -> - scan_root_entry t - (Allocator.unsafe_from_offheap k) - (Allocator.unsafe_from_offheap mv)) + scan_root_entry t (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value mv)) t; (* Phase 1b: scan edge entries — seed delete queue for removed targets, @@ -673,8 +670,8 @@ let apply_list t ~roots ~edges = ReactiveWave.iter_with edges (fun t src mv -> scan_edge_entry t - (Allocator.unsafe_from_offheap src) - (Allocator.unsafe_from_offheap mv)) + (Offheap.unsafe_to_value src) + (Offheap.unsafe_to_value mv)) t; Invariants.assert_edge_has_new_consistent @@ -685,7 +682,7 @@ let apply_list t ~roots ~edges = (* Phase 2: delete BFS *) while not (ReactiveFifo.is_empty t.delete_queue) do - let k = Allocator.unsafe_from_offheap (ReactiveFifo.pop t.delete_queue) in + let k = Offheap.unsafe_to_value (ReactiveFifo.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; @@ -701,8 +698,8 @@ let apply_list t ~roots ~edges = ReactiveWave.iter_with roots (fun t k mv -> apply_root_mutation t - (Allocator.unsafe_from_offheap k) - (Allocator.unsafe_from_offheap mv)) + (Offheap.unsafe_to_value k) + (Offheap.unsafe_to_value mv)) t; (* Apply edge updates by draining edge_change_queue. *) @@ -713,7 +710,7 @@ let apply_list t ~roots ~edges = if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () in apply_edge_update t - ~src:(Allocator.unsafe_from_offheap src) + ~src:(Offheap.unsafe_to_value src) ~new_successors:new_succs done; (* Rebuild edge_change_queue from new_successors_for_changed keys for @@ -732,8 +729,7 @@ let apply_list t ~roots ~edges = ReactiveSet.clear t.rederive_pending; ReactiveSet.iter_with - (fun t k -> - enqueue_rederive_if_needed_kv t (Allocator.unsafe_from_offheap k)) + (fun t k -> enqueue_rederive_if_needed_kv t (Offheap.unsafe_to_value k)) t t.deleted_nodes; while not (ReactiveFifo.is_empty t.rederive_queue) do @@ -743,7 +739,7 @@ let apply_list t ~roots ~edges = if ReactiveSet.mem t.deleted_nodes k && (not (ReactiveSet.mem t.current k)) - && is_supported t (Allocator.unsafe_from_offheap k) + && is_supported t (Offheap.unsafe_to_value k) then ( ReactiveSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; @@ -765,15 +761,14 @@ let apply_list t ~roots ~edges = (* Seed expansion from added roots *) while not (ReactiveFifo.is_empty t.added_roots_queue) do - add_live t - (Allocator.unsafe_from_offheap (ReactiveFifo.pop t.added_roots_queue)) + add_live t (Offheap.unsafe_to_value (ReactiveFifo.pop t.added_roots_queue)) done; (* Seed expansion from edge changes with new edges *) while not (ReactiveFifo.is_empty t.edge_change_queue) do let src = ReactiveFifo.pop t.edge_change_queue in if ReactiveSet.mem t.current src && ReactiveSet.mem t.edge_has_new src then - enqueue_expand t (Allocator.unsafe_from_offheap src) + enqueue_expand t (Offheap.unsafe_to_value src) done; while not (ReactiveFifo.is_empty t.expansion_queue) do @@ -788,15 +783,14 @@ let apply_list t ~roots ~edges = OffheapList.iter_with add_live t succs) done; ReactiveSet.iter_with - (fun t k -> emit_removal t (Allocator.unsafe_from_offheap k) ()) + (fun t k -> emit_removal t (Offheap.unsafe_to_value k) ()) t t.deleted_nodes; let output_entries_list = if Invariants.enabled then ( let entries = ref [] in ReactiveWave.iter t.output_wave (fun k v_opt -> entries := - ( Allocator.unsafe_from_offheap k, - Allocator.unsafe_from_offheap v_opt ) + (Offheap.unsafe_to_value k, Offheap.unsafe_to_value v_opt) :: !entries); !entries) else [] diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 94e335134e7..1f0efded313 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -35,15 +35,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k2) + ReactiveSet.add t.affected (Offheap.unsafe_of_value k2) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k2) - (Allocator.unsafe_to_offheap v2) + (Offheap.unsafe_of_value k2) + (Offheap.unsafe_of_value v2) let create ~f ~merge = let rec t = @@ -87,7 +87,7 @@ let push t k v_opt = ReactiveMap.replace t.scratch k v_opt let remove_one_contribution (t : (_, _, _, _) t) k2 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 t.current_k1; - ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k2) + ReactiveSet.add t.affected (Offheap.unsafe_of_value k2) let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; @@ -101,27 +101,27 @@ let merge_one_contribution (t : (_, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _) t) k2 = - let k2 = Allocator.unsafe_from_offheap k2 in + let k2 = Offheap.unsafe_to_value k2 in if ReactivePoolMapMap.inner_cardinal t.contributions k2 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k2) - (Allocator.unsafe_to_offheap t.merge_acc); + (Offheap.unsafe_of_value k2) + (Offheap.unsafe_of_value t.merge_acc); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k2) - (Allocator.unsafe_to_offheap (Maybe.some t.merge_acc))) + (Offheap.unsafe_of_value k2) + (Offheap.unsafe_of_value (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (Allocator.unsafe_to_offheap k2); + ReactiveMap.remove t.target (Offheap.unsafe_of_value k2); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k2) + (Offheap.unsafe_of_value k2) Maybe.none_offheap) (* Single-pass process + count for scratch *) let process_scratch_entry (t : (_, _, _, _) t) k1 mv = - let k1 = Allocator.unsafe_from_offheap k1 in - let mv = Allocator.unsafe_from_offheap mv in + let k1 = Offheap.unsafe_to_value k1 in + let mv = Offheap.unsafe_to_value mv in t.result.entries_received <- t.result.entries_received + 1; remove_source t k1; if Maybe.is_some mv then ( @@ -132,7 +132,7 @@ let process_scratch_entry (t : (_, _, _, _) t) k1 mv = else t.result.removes_received <- t.result.removes_received + 1 let count_output_entry (r : process_result) _k mv = - let mv = Allocator.unsafe_from_offheap mv in + let mv = Offheap.unsafe_to_value mv in if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 @@ -164,15 +164,13 @@ let init_entry (t : (_, _, _, _) t) k1 v1 = let iter_target f t = ReactiveMap.iter - (fun k v -> - f (Allocator.unsafe_from_offheap k) (Allocator.unsafe_from_offheap v)) + (fun k v -> f (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Allocator.unsafe_to_offheap k) - |> Maybe.to_option + ReactiveMap.find_maybe t.target (Offheap.unsafe_of_value k) |> Maybe.to_option |> function - | Some v -> Maybe.some (Allocator.unsafe_from_offheap v) + | Some v -> Maybe.some (Offheap.unsafe_to_value v) | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 6e21c84a3d7..5f1c3e77b8a 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -26,10 +26,7 @@ val output_wave : ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) val push : - ('k1, 'v1, 'k2, 'v2) t -> - 'k1 Allocator.offheap -> - 'v1 Maybe.t Allocator.offheap -> - unit + ('k1, 'v1, 'k2, 'v2) t -> 'k1 Offheap.t -> 'v1 Maybe.t Offheap.t -> unit (** Push an entry into the scratch table. *) val process : ('k1, 'v1, 'k2, 'v2) t -> process_result diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index ec6bc53bdf7..4eec3b786ec 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -41,15 +41,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k3) + ReactiveSet.add t.affected (Offheap.unsafe_of_value k3) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k3) - (Allocator.unsafe_to_offheap v3) + (Offheap.unsafe_of_value k3) + (Offheap.unsafe_of_value v3) let create ~key_of ~f ~merge ~right_get = let rec t = @@ -104,7 +104,7 @@ let push_right t k v_opt = ReactiveMap.replace t.right_scratch k v_opt let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 t.current_k1; - ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k3) + ReactiveSet.add t.affected (Offheap.unsafe_of_value k3) let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; @@ -112,11 +112,11 @@ let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = let mb = - ReactiveMap.find_maybe t.left_to_right_key (Allocator.unsafe_to_offheap k1) + ReactiveMap.find_maybe t.left_to_right_key (Offheap.unsafe_of_value k1) in if Maybe.is_some mb then ( - let old_k2 = Allocator.unsafe_from_offheap (Maybe.unsafe_get mb) in - ReactiveMap.remove t.left_to_right_key (Allocator.unsafe_to_offheap k1); + let old_k2 = Offheap.unsafe_to_value (Maybe.unsafe_get mb) in + ReactiveMap.remove t.left_to_right_key (Offheap.unsafe_of_value k1); ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys old_k2 k1) @@ -125,15 +125,15 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = unlink_right_key t k1; let k2 = t.key_of k1 v1 in ReactiveMap.replace t.left_to_right_key - (Allocator.unsafe_to_offheap k1) - (Allocator.unsafe_to_offheap k2); + (Offheap.unsafe_of_value k1) + (Offheap.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; t.f k1 v1 right_val t.emit_fn let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = - ReactiveMap.remove t.left_entries (Allocator.unsafe_to_offheap k1); + ReactiveMap.remove t.left_entries (Offheap.unsafe_of_value k1); remove_left_contributions t k1; unlink_right_key t k1 @@ -145,34 +145,34 @@ let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _, _, _) t) k3 = - let k3 = Allocator.unsafe_from_offheap k3 in + let k3 = Offheap.unsafe_to_value k3 in if ReactivePoolMapMap.inner_cardinal t.contributions k3 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k3) - (Allocator.unsafe_to_offheap t.merge_acc); + (Offheap.unsafe_of_value k3) + (Offheap.unsafe_of_value t.merge_acc); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k3) - (Allocator.unsafe_to_offheap (Maybe.some t.merge_acc))) + (Offheap.unsafe_of_value k3) + (Offheap.unsafe_of_value (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (Allocator.unsafe_to_offheap k3); + ReactiveMap.remove t.target (Offheap.unsafe_of_value k3); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k3) + (Offheap.unsafe_of_value k3) Maybe.none_offheap) (* Single-pass process + count for left scratch *) let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = - let k1 = Allocator.unsafe_from_offheap k1 in - let mv = Allocator.unsafe_from_offheap mv in + let k1 = Offheap.unsafe_to_value k1 in + let mv = Offheap.unsafe_to_value 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 ReactiveMap.replace t.left_entries - (Allocator.unsafe_to_offheap k1) - (Allocator.unsafe_to_offheap v1); + (Offheap.unsafe_of_value k1) + (Offheap.unsafe_of_value v1); process_left_entry t k1 v1) else ( t.result.removes_received <- t.result.removes_received + 1; @@ -180,17 +180,14 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = - let mb = - ReactiveMap.find_maybe t.left_entries (Allocator.unsafe_to_offheap k1) - in + let mb = ReactiveMap.find_maybe t.left_entries (Offheap.unsafe_of_value k1) in if Maybe.is_some mb then - process_left_entry t k1 - (Allocator.unsafe_from_offheap (Maybe.unsafe_get mb)) + process_left_entry t k1 (Offheap.unsafe_to_value (Maybe.unsafe_get mb)) (* Single-pass process + count for right scratch *) let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = - let k2 = Allocator.unsafe_from_offheap k2 in - let _mv = Allocator.unsafe_from_offheap _mv in + let k2 = Offheap.unsafe_to_value k2 in + let _mv = Offheap.unsafe_to_value _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; @@ -199,7 +196,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = ReactiveHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = - let mv = Allocator.unsafe_from_offheap mv in + let mv = Offheap.unsafe_to_value mv in if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 @@ -230,12 +227,12 @@ let process (t : (_, _, _, _, _, _) t) = let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = ReactiveMap.replace t.left_entries - (Allocator.unsafe_to_offheap k1) - (Allocator.unsafe_to_offheap v1); + (Offheap.unsafe_of_value k1) + (Offheap.unsafe_of_value v1); let k2 = t.key_of k1 v1 in ReactiveMap.replace t.left_to_right_key - (Allocator.unsafe_to_offheap k1) - (Allocator.unsafe_to_offheap k2); + (Offheap.unsafe_of_value k1) + (Offheap.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; @@ -243,15 +240,13 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = let iter_target f t = ReactiveMap.iter - (fun k v -> - f (Allocator.unsafe_from_offheap k) (Allocator.unsafe_from_offheap v)) + (fun k v -> f (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Allocator.unsafe_to_offheap k) - |> Maybe.to_option + ReactiveMap.find_maybe t.target (Offheap.unsafe_of_value k) |> Maybe.to_option |> function - | Some v -> Maybe.some (Allocator.unsafe_from_offheap v) + | Some v -> Maybe.some (Offheap.unsafe_to_value v) | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index ff7964f46e9..0ebf789bb9c 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -30,15 +30,15 @@ val output_wave : val push_left : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> - 'k1 Allocator.offheap -> - 'v1 Maybe.t Allocator.offheap -> + 'k1 Offheap.t -> + 'v1 Maybe.t Offheap.t -> unit (** Push an entry into the left scratch table. *) val push_right : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> - 'k2 Allocator.offheap -> - 'v2 Maybe.t Allocator.offheap -> + 'k2 Offheap.t -> + 'v2 Maybe.t Offheap.t -> unit (** Push an entry into the right scratch table. *) diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/ReactiveMap.ml index bf0ace58418..250ece715bc 100644 --- a/analysis/reactive/src/ReactiveMap.ml +++ b/analysis/reactive/src/ReactiveMap.ml @@ -9,8 +9,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 Allocator.offheap = Obj.magic empty_sentinel -let[@inline] tomb_slot () : 'a Allocator.offheap = Obj.magic tomb_sentinel +let[@inline] empty_slot () : 'a Offheap.t = Obj.magic empty_sentinel +let[@inline] tomb_slot () : 'a Offheap.t = Obj.magic tomb_sentinel let key_capacity t = Allocator.Block2.capacity t.keys let population t = Allocator.Block2.get0 t.keys @@ -19,8 +19,7 @@ let occupation t = Allocator.Block2.get1 t.keys let set_occupation t n = Allocator.Block2.set1 t.keys n let[@inline] mask t = key_capacity t - 1 -let[@inline] start t x = - Hashtbl.hash (Allocator.unsafe_from_offheap x) land mask t +let[@inline] start t x = Hashtbl.hash (Offheap.unsafe_to_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 @@ -47,7 +46,7 @@ let clear t = clear_keys t let insert_absent t k v = - let empty : 'k Allocator.offheap = empty_slot () in + let empty : 'k Offheap.t = empty_slot () in let j = ref (start t k) in while Allocator.Block2.get t.keys !j != empty do j := next t !j @@ -85,8 +84,8 @@ let maybe_grow_before_insert t = let replace t k v = maybe_grow_before_insert t; - let empty : 'k Allocator.offheap = empty_slot () in - let tomb : 'k Allocator.offheap = tomb_slot () in + let empty : 'k Offheap.t = empty_slot () in + let tomb : 'k Offheap.t = tomb_slot () in let j = ref (start t k) in let first_tomb = ref (-1) in let done_ = ref false in @@ -109,8 +108,8 @@ let replace t k v = done let remove t k = - let empty : 'k Allocator.offheap = empty_slot () in - let tomb : 'k Allocator.offheap = tomb_slot () in + let empty : 'k Offheap.t = empty_slot () in + let tomb : 'k Offheap.t = tomb_slot () in let j = ref (start t k) in let done_ = ref false in while not !done_ do @@ -125,8 +124,8 @@ let remove t k = done let mem t k = - let empty : 'k Allocator.offheap = empty_slot () in - let tomb : 'k Allocator.offheap = tomb_slot () in + let empty : 'k Offheap.t = empty_slot () in + let tomb : 'k Offheap.t = tomb_slot () in let j = ref (start t k) in let found = ref false in let done_ = ref false in @@ -142,8 +141,8 @@ let mem t k = !found let find_maybe t k = - let empty : 'k Allocator.offheap = empty_slot () in - let tomb : 'k Allocator.offheap = tomb_slot () in + let empty : 'k Offheap.t = empty_slot () in + let tomb : 'k Offheap.t = tomb_slot () in let j = ref (start t k) in let found = ref Maybe.none in let done_ = ref false in @@ -159,8 +158,8 @@ let find_maybe t k = !found let iter_with f arg t = - let empty : 'k Allocator.offheap = empty_slot () in - let tomb : 'k Allocator.offheap = tomb_slot () in + let empty : 'k Offheap.t = empty_slot () in + let tomb : 'k Offheap.t = tomb_slot () in if population t > 0 then for i = 0 to key_capacity t - 1 do let k = Allocator.Block2.get t.keys i in diff --git a/analysis/reactive/src/ReactiveMap.mli b/analysis/reactive/src/ReactiveMap.mli index b93a5e834a2..890e86ebe08 100644 --- a/analysis/reactive/src/ReactiveMap.mli +++ b/analysis/reactive/src/ReactiveMap.mli @@ -6,22 +6,17 @@ val create : unit -> ('k, 'v) t val destroy : ('k, 'v) t -> unit val clear : ('k, 'v) t -> unit -val replace : ('k, 'v) t -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit +val replace : ('k, 'v) t -> 'k Offheap.t -> 'v Offheap.t -> unit -val remove : ('k, 'v) t -> 'k Allocator.offheap -> unit +val remove : ('k, 'v) t -> 'k Offheap.t -> unit -val mem : ('k, 'v) t -> 'k Allocator.offheap -> bool +val mem : ('k, 'v) t -> 'k Offheap.t -> bool -val find_maybe : - ('k, 'v) t -> 'k Allocator.offheap -> 'v Allocator.offheap Maybe.t +val find_maybe : ('k, 'v) t -> 'k Offheap.t -> 'v Offheap.t Maybe.t val iter_with : - ('a -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit) -> - 'a -> - ('k, 'v) t -> - unit + ('a -> 'k Offheap.t -> 'v Offheap.t -> unit) -> 'a -> ('k, 'v) t -> unit -val iter : - ('k Allocator.offheap -> 'v Allocator.offheap -> unit) -> ('k, 'v) t -> unit +val iter : ('k Offheap.t -> 'v Offheap.t -> unit) -> ('k, 'v) t -> unit val cardinal : ('k, 'v) t -> int diff --git a/analysis/reactive/src/ReactiveSet.ml b/analysis/reactive/src/ReactiveSet.ml index 2d5c3e4d862..9e94a10a403 100644 --- a/analysis/reactive/src/ReactiveSet.ml +++ b/analysis/reactive/src/ReactiveSet.ml @@ -3,7 +3,7 @@ - ['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 Allocator.offheap]. + - Data slots: keys, stored as ['a Offheap.t]. The backing block lives off-heap. Elements are ordinary OCaml values whose storage invariant has already been established before insertion. @@ -20,9 +20,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 Allocator.offheap) -let[@inline] tomb_sentinel = fun () -> (Obj.magic tomb : 'a Allocator.offheap) +let[@inline] empty_sentinel = fun () -> (Obj.magic sentinel : 'a Offheap.t) +let[@inline] tomb_sentinel = fun () -> (Obj.magic tomb : 'a Offheap.t) let slot_capacity = Allocator.Block2.capacity let population = Allocator.Block2.get0 @@ -30,8 +29,7 @@ let set_population = Allocator.Block2.set0 let mask = Allocator.Block2.get1 let set_mask = Allocator.Block2.set1 -let[@inline] start t x = - Hashtbl.hash (Allocator.unsafe_from_offheap x) land mask t +let[@inline] start t x = Hashtbl.hash (Offheap.unsafe_to_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 @@ -55,7 +53,7 @@ let clear t = set_population t 0; clear_slots t -let add_absent_key (type a) (t : a t) (x : a Allocator.offheap) = +let add_absent_key (type a) (t : a t) (x : a Offheap.t) = let j = ref (start t x) in while let current = Allocator.Block2.get t !j in @@ -85,7 +83,7 @@ let maybe_grow_before_add (type a) (t : a t) = 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 Allocator.offheap) = +let add (type a) (t : a t) (x : a Offheap.t) = maybe_grow_before_add t; let j = ref (start t x) in let first_tomb = ref (-1) in @@ -104,7 +102,7 @@ let add (type a) (t : a t) (x : a Allocator.offheap) = else j := next t !j done -let remove (type a) (t : a t) (x : a Allocator.offheap) = +let remove (type a) (t : a t) (x : a Offheap.t) = let j = ref (start t x) in let done_ = ref false in while not !done_ do @@ -118,7 +116,7 @@ let remove (type a) (t : a t) (x : a Allocator.offheap) = else j := next t !j done -let mem (type a) (t : a t) (x : a Allocator.offheap) = +let mem (type a) (t : a t) (x : a Offheap.t) = let j = ref (start t x) in let found = ref false in let done_ = ref false in @@ -133,8 +131,7 @@ let mem (type a) (t : a t) (x : a Allocator.offheap) = done; !found -let iter_with (type a k) (f : a -> k Allocator.offheap -> unit) (arg : a) - (t : k t) = +let iter_with (type a k) (f : a -> k Offheap.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 diff --git a/analysis/reactive/src/ReactiveSet.mli b/analysis/reactive/src/ReactiveSet.mli index ea3113a05e0..aba3b9405f2 100644 --- a/analysis/reactive/src/ReactiveSet.mli +++ b/analysis/reactive/src/ReactiveSet.mli @@ -15,16 +15,16 @@ val destroy : 'a t -> unit val clear : 'a t -> unit (** Remove all elements while keeping the current storage. *) -val add : 'a t -> 'a Allocator.offheap -> unit +val add : 'a t -> 'a Offheap.t -> unit (** Add an element to the set. Re-adding an existing element is a no-op. *) -val remove : 'a t -> 'a Allocator.offheap -> unit +val remove : 'a t -> 'a Offheap.t -> unit (** Remove an element from the set. Removing a missing element is a no-op. *) -val mem : 'a t -> 'a Allocator.offheap -> bool +val mem : 'a t -> 'a Offheap.t -> bool (** Test whether the set contains an element. *) -val iter_with : ('b -> 'a Allocator.offheap -> unit) -> 'b -> 'a t -> unit +val iter_with : ('b -> 'a Offheap.t -> unit) -> 'b -> 'a t -> unit (** [iter_with f arg t] calls [f arg x] for each element. *) val cardinal : 'a t -> int diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml index 64738bb86d3..af40716a095 100644 --- a/analysis/reactive/src/ReactiveTable.ml +++ b/analysis/reactive/src/ReactiveTable.ml @@ -10,13 +10,13 @@ let capacity (t : 'a t) = Allocator.Block.capacity t - data_offset let create ~initial_capacity : 'a t = if initial_capacity < 0 then invalid_arg "ReactiveTable.create"; let t = Allocator.Block.create ~capacity:(initial_capacity + data_offset) in - Allocator.Block.set t length_slot (Obj.magic (Allocator.int_to_offheap 0)); + Allocator.Block.set t length_slot (Obj.magic (Offheap.int 0)); t let destroy = Allocator.Block.destroy let clear (t : 'a t) = - Allocator.Block.set t length_slot (Obj.magic (Allocator.int_to_offheap 0)) + Allocator.Block.set t length_slot (Obj.magic (Offheap.int 0)) let ensure_capacity (t : 'a t) needed = let old_capacity = capacity t in @@ -42,15 +42,13 @@ let push (t : 'a t) value = let next_len = len + 1 in ensure_capacity t next_len; Allocator.Block.set t (len + data_offset) (Obj.magic value); - Allocator.Block.set t length_slot - (Obj.magic (Allocator.int_to_offheap next_len)) + Allocator.Block.set t length_slot (Obj.magic (Offheap.int next_len)) let pop (t : 'a t) = let len = length t in if len = 0 then invalid_arg "ReactiveTable.pop"; let last = Obj.magic (Allocator.Block.get t (len - 1 + data_offset)) in - Allocator.Block.set t length_slot - (Obj.magic (Allocator.int_to_offheap (len - 1))); + Allocator.Block.set t length_slot (Obj.magic (Offheap.int (len - 1))); last let shrink_to_fit (t : 'a t) = diff --git a/analysis/reactive/src/ReactiveTable.mli b/analysis/reactive/src/ReactiveTable.mli index d67480a9cd8..8cf2242cf8f 100644 --- a/analysis/reactive/src/ReactiveTable.mli +++ b/analysis/reactive/src/ReactiveTable.mli @@ -32,13 +32,13 @@ val capacity : 'a t -> int val clear : 'a t -> unit (** Remove all elements from the table without releasing its storage. *) -val get : 'a t -> int -> 'a Allocator.offheap -val set : 'a t -> int -> 'a Allocator.offheap -> unit +val get : 'a t -> int -> 'a Offheap.t +val set : 'a t -> int -> 'a Offheap.t -> unit -val push : 'a t -> 'a Allocator.offheap -> unit +val push : 'a t -> 'a Offheap.t -> unit (** Append an element, growing via the allocator when needed. *) -val pop : 'a t -> 'a Allocator.offheap +val pop : 'a t -> 'a Offheap.t (** Remove and return the last element. *) val shrink_to_fit : 'a t -> unit diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index 8112b4c6a0d..f3f66f1b3ec 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -60,79 +60,75 @@ let push_right t k mv = ReactiveMap.replace t.right_scratch k mv (* Module-level helpers for iter_with — avoid closure allocation *) let apply_left_entry t k mv = - let k = Allocator.unsafe_from_offheap k in - let mv = Allocator.unsafe_from_offheap mv in + let k = Offheap.unsafe_to_value k in + let mv = Offheap.unsafe_to_value mv in let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( ReactiveMap.replace t.left_values - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.unsafe_get mv)); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.left_values (Allocator.unsafe_to_offheap k); + ReactiveMap.remove t.left_values (Offheap.unsafe_of_value k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k) + ReactiveSet.add t.affected (Offheap.unsafe_of_value k) let apply_right_entry t k mv = - let k = Allocator.unsafe_from_offheap k in - let mv = Allocator.unsafe_from_offheap mv in + let k = Offheap.unsafe_to_value k in + let mv = Offheap.unsafe_to_value mv in let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( ReactiveMap.replace t.right_values - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.unsafe_get mv)); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.right_values (Allocator.unsafe_to_offheap k); + ReactiveMap.remove t.right_values (Offheap.unsafe_of_value k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (Allocator.unsafe_to_offheap k) + ReactiveSet.add t.affected (Offheap.unsafe_of_value k) let recompute_affected_entry t k = - let k = Allocator.unsafe_from_offheap k in + let k = Offheap.unsafe_to_value k in let r = t.result in - let lv = - ReactiveMap.find_maybe t.left_values (Allocator.unsafe_to_offheap k) - in - let rv = - ReactiveMap.find_maybe t.right_values (Allocator.unsafe_to_offheap k) - in + let lv = ReactiveMap.find_maybe t.left_values (Offheap.unsafe_of_value k) in + let rv = ReactiveMap.find_maybe t.right_values (Offheap.unsafe_of_value 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 - (Allocator.unsafe_from_offheap (Maybe.unsafe_get lv)) - (Allocator.unsafe_from_offheap (Maybe.unsafe_get rv)) + (Offheap.unsafe_to_value (Maybe.unsafe_get lv)) + (Offheap.unsafe_to_value (Maybe.unsafe_get rv)) in ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap merged); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value merged); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.some merged))) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.some merged))) else - let v = Allocator.unsafe_from_offheap (Maybe.unsafe_get lv) in + let v = Offheap.unsafe_to_value (Maybe.unsafe_get lv) in ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap v); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value v); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.some v))) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.some v))) else if has_right then ( - let v = Allocator.unsafe_from_offheap (Maybe.unsafe_get rv) in + let v = Offheap.unsafe_to_value (Maybe.unsafe_get rv) in ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap v); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value v); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.some v))) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.some v))) else ( - ReactiveMap.remove t.target (Allocator.unsafe_to_offheap k); + ReactiveMap.remove t.target (Offheap.unsafe_of_value k); ReactiveWave.push t.output_wave - (Allocator.unsafe_to_offheap k) + (Offheap.unsafe_of_value k) Maybe.none_offheap); r.entries_emitted <- r.entries_emitted + 1; if has_left || has_right then r.adds_emitted <- r.adds_emitted + 1 @@ -162,39 +158,35 @@ let process t = let init_left t k v = ReactiveMap.replace t.left_values - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap v); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value v); ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap v) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value v) let init_right t k v = ReactiveMap.replace t.right_values - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap v); - let lv = - ReactiveMap.find_maybe t.left_values (Allocator.unsafe_to_offheap k) - in + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value v); + let lv = ReactiveMap.find_maybe t.left_values (Offheap.unsafe_of_value k) in let merged = if Maybe.is_some lv then - t.merge (Allocator.unsafe_from_offheap (Maybe.unsafe_get lv)) v + t.merge (Offheap.unsafe_to_value (Maybe.unsafe_get lv)) v else v in ReactiveMap.replace t.target - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap merged) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value merged) let iter_target f t = ReactiveMap.iter - (fun k v -> - f (Allocator.unsafe_from_offheap k) (Allocator.unsafe_from_offheap v)) + (fun k v -> f (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Allocator.unsafe_to_offheap k) - |> Maybe.to_option + ReactiveMap.find_maybe t.target (Offheap.unsafe_of_value k) |> Maybe.to_option |> function - | Some v -> Maybe.some (Allocator.unsafe_from_offheap v) + | Some v -> Maybe.some (Offheap.unsafe_to_value v) | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index 6f68273aa28..f9c5db642e0 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -23,12 +23,10 @@ val destroy : ('k, 'v) t -> unit val output_wave : ('k, 'v) t -> ('k, 'v Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) -val push_left : - ('k, 'v) t -> 'k Allocator.offheap -> 'v Maybe.t Allocator.offheap -> unit +val push_left : ('k, 'v) t -> 'k Offheap.t -> 'v Maybe.t Offheap.t -> unit (** Push an entry into the left scratch table. *) -val push_right : - ('k, 'v) t -> 'k Allocator.offheap -> 'v Maybe.t Allocator.offheap -> unit +val push_right : ('k, 'v) t -> 'k Offheap.t -> 'v Maybe.t Offheap.t -> unit (** Push an entry into the right scratch table. *) val process : ('k, 'v) t -> process_result diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index 581cd63c1c1..f357eae5295 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -28,8 +28,7 @@ let ensure_capacity (t : ('k, 'v) t) needed = done; Allocator.Block2.resize t ~capacity:(!next * entry_width)) -let push (type k v) (t : (k, v) t) (k : k Allocator.offheap) - (v : v Allocator.offheap) = +let push (type k v) (t : (k, v) t) (k : k Offheap.t) (v : v Offheap.t) = let len = length t in ensure_capacity t (len + 1); let key_slot = len * entry_width in @@ -37,8 +36,7 @@ let push (type k v) (t : (k, v) t) (k : k Allocator.offheap) 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 Allocator.offheap -> v Allocator.offheap -> unit) = +let iter (type k v) (t : (k, v) t) (f : k Offheap.t -> v Offheap.t -> unit) = let len = length t in for i = 0 to len - 1 do let key_slot = i * entry_width in @@ -48,7 +46,7 @@ let iter (type k v) (t : (k, v) t) done let iter_with (type a k v) (t : (k, v) t) - (f : a -> k Allocator.offheap -> v Allocator.offheap -> unit) (arg : a) = + (f : a -> k Offheap.t -> v Offheap.t -> unit) (arg : a) = let len = length t in for i = 0 to len - 1 do let key_slot = i * entry_width in diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli index 211435ea49e..01ecbd279b2 100644 --- a/analysis/reactive/src/ReactiveWave.mli +++ b/analysis/reactive/src/ReactiveWave.mli @@ -1,6 +1,6 @@ (** A wave is a growable batch of key/value entries stored in off-heap allocator-backed storage. Its API is marked with - [Allocator.offheap] so call sites make the boundary explicit. + [Offheap.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. *) @@ -16,18 +16,14 @@ val clear : ('k, 'v) t -> unit val destroy : ('k, 'v) t -> unit (** Release the wave's off-heap storage. The wave must not be used after this. *) -val push : ('k, 'v) t -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit +val push : ('k, 'v) t -> 'k Offheap.t -> 'v Offheap.t -> unit (** Append one off-heap-marked entry to the wave. Callers are currently responsible for establishing the off-heap invariant before calling. *) -val iter : - ('k, 'v) t -> ('k Allocator.offheap -> 'v Allocator.offheap -> unit) -> unit +val iter : ('k, 'v) t -> ('k Offheap.t -> 'v Offheap.t -> unit) -> unit val iter_with : - ('k, 'v) t -> - ('a -> 'k Allocator.offheap -> 'v Allocator.offheap -> unit) -> - 'a -> - unit + ('k, 'v) t -> ('a -> 'k Offheap.t -> 'v Offheap.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. *) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 6cd1bbe9997..7250fa25a54 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -7,9 +7,9 @@ open TestHelpers let words_since = AllocMeasure.words_since -let off = Allocator.unsafe_to_offheap -let off_int = Allocator.int_to_offheap -let off_unit = Allocator.unit_to_offheap +let off = Offheap.unsafe_of_value +let off_int = Offheap.int +let off_unit = Offheap.unit let off_maybe_int = Maybe.maybe_int_to_offheap let off_maybe_unit = Maybe.maybe_unit_to_offheap @@ -48,8 +48,7 @@ let test_fixpoint_alloc_n n = (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) ReactiveWave.push root_snap (off_int 0) (off_unit ()); for i = 0 to n - 2 do - ReactiveWave.push edge_snap (off_int i) - (Allocator.to_offheap edge_values.(i)) + ReactiveWave.push edge_snap (off_int i) (Offheap.of_value edge_values.(i)) done; ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; assert (ReactiveFixpoint.current_length state = n); diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index b58229631d7..a9fbbf4caa7 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -19,8 +19,8 @@ let track_deltas c = c.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> - let k = Allocator.unsafe_from_offheap k in - let mv = Allocator.unsafe_from_offheap mv in + let k = Offheap.unsafe_to_value k in + let mv = Offheap.unsafe_to_value mv in rev_entries := (k, mv) :: !rev_entries); received := List.rev !rev_entries :: !received); received diff --git a/analysis/reactive/test/TableTest.ml b/analysis/reactive/test/TableTest.ml index ef2fea37e03..b3b33ec768a 100644 --- a/analysis/reactive/test/TableTest.ml +++ b/analysis/reactive/test/TableTest.ml @@ -38,22 +38,20 @@ let test_table_promoted_wave_lifecycle () = ignore (AllocMeasure.words_since ()); ReactiveTable.clear t; for i = 0 to count - 1 do - ReactiveTable.push t (Allocator.to_offheap fresh.(i)) + ReactiveTable.push t (Offheap.of_value fresh.(i)) done; assert (ReactiveTable.length t = count); assert (ReactiveTable.capacity t >= ReactiveTable.length t); - ReactiveTable.set t 0 (Allocator.to_offheap fresh.(count - 1)); - assert ( - Allocator.unsafe_from_offheap (ReactiveTable.get t 0) == fresh.(count - 1)); + ReactiveTable.set t 0 (Offheap.of_value fresh.(count - 1)); + assert (Offheap.unsafe_to_value (ReactiveTable.get t 0) == fresh.(count - 1)); for i = 0 to count - 1 do let expected = if i = 0 then fresh.(count - 1) else fresh.(i) in - let recovered = Allocator.unsafe_from_offheap (ReactiveTable.get t i) in + let recovered = Offheap.unsafe_to_value (ReactiveTable.get t i) in assert (recovered == expected); assert (Bytes.get recovered 0 = Bytes.get expected 0); assert (Bytes.get recovered (width - 1) = Bytes.get expected (width - 1)) done; - assert ( - Allocator.unsafe_from_offheap (ReactiveTable.pop t) == fresh.(count - 1)); + assert (Offheap.unsafe_to_value (ReactiveTable.pop t) == fresh.(count - 1)); assert (ReactiveTable.length t = count - 1); ReactiveTable.shrink_to_fit t; assert (ReactiveTable.capacity t = ReactiveTable.length t); @@ -92,7 +90,7 @@ let test_table_unsafe_minor_heap_demo () = let fresh = Bytes.make width c in Bytes.set fresh 0 c; Bytes.set fresh (width - 1) c; - ReactiveTable.push t (Allocator.unsafe_to_offheap fresh) + ReactiveTable.push t (Offheap.unsafe_of_value fresh) done; Gc.compact (); for round = 1 to 200 do @@ -110,9 +108,7 @@ let test_table_unsafe_minor_heap_demo () = let samples = ref [] in for i = 0 to count - 1 do let expected = Char.chr ((i mod 26) + Char.code 'A') in - let recovered : bytes = - Allocator.unsafe_from_offheap (ReactiveTable.get t i) - in + let recovered : bytes = Offheap.unsafe_to_value (ReactiveTable.get t i) in let ok = Bytes.length recovered = width && Bytes.get recovered 0 = expected diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 9ccb3f7950e..88dd557a333 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -17,8 +17,8 @@ let emit_set emit k v = let w = wave () in ReactiveWave.clear w; ReactiveWave.push w - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.some v)); + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.some v)); emit w (** Emit a single edge-set entry, converting the successor list to the @@ -27,7 +27,7 @@ let emit_edge_set emit k vs = let w = wave () in ReactiveWave.clear w; ReactiveWave.push w - (Allocator.unsafe_to_offheap k) + (Offheap.unsafe_of_value k) (Maybe.maybe_offheap_list_to_offheap (Maybe.some (OffheapList.unsafe_of_list vs))); emit w @@ -36,7 +36,7 @@ let emit_edge_set emit k vs = let emit_remove emit k = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap; + ReactiveWave.push w (Offheap.unsafe_of_value k) Maybe.none_offheap; emit w (** Emit a batch of (key, value) set entries *) @@ -46,8 +46,8 @@ let emit_sets emit entries = List.iter (fun (k, v) -> ReactiveWave.push w - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.some v))) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.some v))) entries; emit w @@ -60,10 +60,10 @@ let emit_batch emit entries = match v_opt with | Some v -> ReactiveWave.push w - (Allocator.unsafe_to_offheap k) - (Allocator.unsafe_to_offheap (Maybe.some v)) + (Offheap.unsafe_of_value k) + (Offheap.unsafe_of_value (Maybe.some v)) | None -> - ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap) + ReactiveWave.push w (Offheap.unsafe_of_value k) Maybe.none_offheap) entries; emit w @@ -76,11 +76,11 @@ let emit_edge_batch emit entries = match vs_opt with | Some vs -> ReactiveWave.push w - (Allocator.unsafe_to_offheap k) + (Offheap.unsafe_of_value k) (Maybe.maybe_offheap_list_to_offheap (Maybe.some (OffheapList.unsafe_of_list vs))) | None -> - ReactiveWave.push w (Allocator.unsafe_to_offheap k) Maybe.none_offheap) + ReactiveWave.push w (Offheap.unsafe_of_value k) Maybe.none_offheap) entries; emit w @@ -91,8 +91,8 @@ let subscribe handler t = t.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> - let k = Allocator.unsafe_from_offheap k in - let mv = Allocator.unsafe_from_offheap mv in + let k = Offheap.unsafe_to_value k in + let mv = Offheap.unsafe_to_value mv in rev_entries := (k, mv) :: !rev_entries); handler (List.rev !rev_entries)) From f70da87fa80486cc465a40e7b8c3fb1c4fddbd93 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 08:19:00 +0100 Subject: [PATCH 26/54] analysis/reactive: finish stable rename cleanup --- analysis/reactive/src/ReactiveFixpoint.ml | 339 +++++++++++----------- analysis/reactive/test/AllocTest.ml | 130 +++++---- analysis/reactive/test/TableTest.ml | 22 +- 3 files changed, 245 insertions(+), 246 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 90ba0806370..852d3e8e71d 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -17,7 +17,7 @@ type 'k metrics_state = { type 'k t = { current: 'k ReactiveSet.t; - edge_map: ('k, 'k OffheapList.inner) ReactiveMap.t; + edge_map: ('k, 'k StableList.inner) ReactiveMap.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; roots: 'k ReactiveSet.t; output_wave: ('k, unit Maybe.t) ReactiveWave.t; @@ -25,64 +25,64 @@ type 'k t = { deleted_nodes: 'k ReactiveSet.t; rederive_pending: 'k ReactiveSet.t; expansion_seen: 'k ReactiveSet.t; - old_successors_for_changed: ('k, 'k OffheapList.inner) ReactiveMap.t; - new_successors_for_changed: ('k, 'k OffheapList.inner) ReactiveMap.t; + old_successors_for_changed: ('k, 'k StableList.inner) ReactiveMap.t; + new_successors_for_changed: ('k, 'k StableList.inner) ReactiveMap.t; (* Scratch sets for analyze_edge_change / apply_edge_update *) scratch_set_a: 'k ReactiveSet.t; scratch_set_b: 'k ReactiveSet.t; edge_has_new: 'k ReactiveSet.t; (* Scratch queues *) - delete_queue: 'k ReactiveFifo.t; - rederive_queue: 'k ReactiveFifo.t; - expansion_queue: 'k ReactiveFifo.t; - added_roots_queue: 'k ReactiveFifo.t; - edge_change_queue: 'k ReactiveFifo.t; + 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; } (* Standalone version for Invariants (no scratch sets available). Debug-only — allocates temporary Hashtbl. *) let analyze_edge_change_has_new ~old_succs ~new_succs = - if OffheapList.is_empty old_succs then not (OffheapList.is_empty new_succs) - else if OffheapList.is_empty new_succs then false + if StableList.is_empty old_succs then not (StableList.is_empty new_succs) + else if StableList.is_empty new_succs then false else - let old_set = Hashtbl.create (OffheapList.length old_succs) in - OffheapList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; - OffheapList.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs + let old_set = Hashtbl.create (StableList.length old_succs) in + StableList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; + StableList.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs -let[@inline] off_key k = Offheap.unsafe_of_value k -let[@inline] enqueue q k = ReactiveFifo.push q (off_key k) +let[@inline] stable_key k = Stable.unsafe_of_value k +let[@inline] enqueue q k = StableQueue.push q (stable_key k) (* 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_root visited frontier _t k () = - ReactiveSet.add visited (off_key k); + ReactiveSet.add visited (stable_key k); enqueue frontier k let bfs_visit_succ visited frontier succ = - if not (ReactiveSet.mem visited (off_key succ)) then ( - ReactiveSet.add visited (off_key succ); + if not (ReactiveSet.mem visited (stable_key succ)) then ( + ReactiveSet.add visited (stable_key succ); enqueue frontier succ) let compute_reachable ~visited t = ReactiveSet.clear visited; let frontier = t.delete_queue in - ReactiveFifo.clear frontier; + StableQueue.clear frontier; let node_work = ref 0 in let edge_work = ref 0 in ReactiveSet.iter_with (fun (visited, frontier) k -> - bfs_seed_root visited frontier t (Offheap.unsafe_to_value k) ()) + bfs_seed_root visited frontier t (Stable.unsafe_to_value k) ()) (visited, frontier) t.roots; - while not (ReactiveFifo.is_empty frontier) do - let k = ReactiveFifo.pop frontier in + while not (StableQueue.is_empty frontier) do + let k = StableQueue.pop frontier in incr node_work; let r = ReactiveMap.find_maybe t.edge_map k in if Maybe.is_some r then ( let succs = Maybe.unsafe_get r in - edge_work := !edge_work + OffheapList.length succs; - OffheapList.iter_with (bfs_visit_succ visited) frontier succs) + edge_work := !edge_work + StableList.length succs; + StableList.iter_with (bfs_visit_succ visited) frontier succs) done; (!node_work, !edge_work) @@ -230,7 +230,7 @@ module Invariants = struct let copy_set_to_hashtbl (s : 'k ReactiveSet.t) = let out = Hashtbl.create (ReactiveSet.cardinal s) in ReactiveSet.iter_with - (fun out k -> Hashtbl.replace out (Offheap.unsafe_to_value k) ()) + (fun out k -> Hashtbl.replace out (Stable.unsafe_to_value k) ()) out s; out @@ -244,60 +244,58 @@ module Invariants = struct let assert_edge_has_new_consistent ~edge_change_queue ~old_successors_for_changed ~new_successors_for_changed ~edge_has_new = if enabled then ( - let q_copy = ReactiveFifo.create () in + let q_copy = StableQueue.create () in (* Drain and re-push to iterate without consuming *) let items = ref [] in - while not (ReactiveFifo.is_empty edge_change_queue) do - let src = - Offheap.unsafe_to_value (ReactiveFifo.pop edge_change_queue) - in + while not (StableQueue.is_empty edge_change_queue) do + let src = Stable.unsafe_to_value (StableQueue.pop edge_change_queue) in items := src :: !items; enqueue q_copy src done; (* Restore queue *) List.iter (fun src -> enqueue edge_change_queue src) (List.rev !items); - ReactiveFifo.destroy q_copy; + StableQueue.destroy q_copy; (* Check each *) List.iter (fun src -> let r_old = - ReactiveMap.find_maybe old_successors_for_changed (off_key src) + ReactiveMap.find_maybe old_successors_for_changed (stable_key src) in let old_succs = if Maybe.is_some r_old then Maybe.unsafe_get r_old - else OffheapList.empty () + else StableList.empty () in let r_new = - ReactiveMap.find_maybe new_successors_for_changed (off_key src) + ReactiveMap.find_maybe new_successors_for_changed (stable_key src) in let new_succs = if Maybe.is_some r_new then Maybe.unsafe_get r_new - else OffheapList.empty () + else StableList.empty () in let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs in - let actual_has_new = ReactiveSet.mem edge_has_new (off_key src) in + let actual_has_new = ReactiveSet.mem edge_has_new (stable_key src) in assert_ (expected_has_new = actual_has_new) "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") !items) let assert_deleted_nodes_closed ~current ~deleted_nodes - ~(old_successors : 'k -> 'k OffheapList.t) = + ~(old_successors : 'k -> 'k StableList.t) = if enabled then ReactiveSet.iter_with (fun () k -> - let k = Offheap.unsafe_to_value k in + let k = Stable.unsafe_to_value k in assert_ - (ReactiveSet.mem current (off_key k)) + (ReactiveSet.mem current (stable_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; - OffheapList.iter + StableList.iter (fun succ -> - if ReactiveSet.mem current (off_key succ) then + if ReactiveSet.mem current (stable_key succ) then assert_ - (ReactiveSet.mem deleted_nodes (off_key succ)) + (ReactiveSet.mem deleted_nodes (stable_key succ)) "ReactiveFixpoint.apply invariant failed: deleted closure \ broken") (old_successors k)) @@ -307,8 +305,8 @@ module Invariants = struct if enabled then ReactiveSet.iter_with (fun () k -> - let k = Offheap.unsafe_to_value k in - if not (ReactiveSet.mem current (off_key k)) then + let k = Stable.unsafe_to_value k in + if not (ReactiveSet.mem current (stable_key k)) then assert_ (not (supported k)) "ReactiveFixpoint.apply invariant failed: supported deleted node \ @@ -319,7 +317,7 @@ module Invariants = struct if enabled then ( let expected = Hashtbl.copy pre_current in ReactiveSet.iter_with - (fun expected k -> Hashtbl.remove expected (Offheap.unsafe_to_value k)) + (fun expected k -> Hashtbl.remove expected (Stable.unsafe_to_value k)) expected deleted_nodes; let current_ht = copy_set_to_hashtbl current in assert_ @@ -332,8 +330,8 @@ module Invariants = struct let expected = Hashtbl.create (ReactiveSet.cardinal deleted_nodes) in ReactiveSet.iter_with (fun expected k -> - let k = Offheap.unsafe_to_value k in - if not (ReactiveSet.mem current (off_key k)) then + let k = Stable.unsafe_to_value k in + if not (ReactiveSet.mem current (stable_key k)) then Hashtbl.replace expected k ()) expected deleted_nodes; let actual = Hashtbl.create (List.length output_entries) in @@ -359,13 +357,13 @@ module Invariants = struct let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in ReactiveSet.iter_with (fun expected_adds k -> - let k = Offheap.unsafe_to_value k in + let k = Stable.unsafe_to_value k in if not (Hashtbl.mem pre_current k) then Hashtbl.replace expected_adds k ()) expected_adds t.current; Hashtbl.iter (fun k () -> - if not (ReactiveSet.mem t.current (off_key k)) then + if not (ReactiveSet.mem t.current (stable_key k)) then Hashtbl.replace expected_removes k ()) pre_current; @@ -412,11 +410,11 @@ let create ~max_nodes ~max_edges = scratch_set_a = ReactiveSet.create (); scratch_set_b = ReactiveSet.create (); edge_has_new = ReactiveSet.create (); - delete_queue = ReactiveFifo.create (); - rederive_queue = ReactiveFifo.create (); - expansion_queue = ReactiveFifo.create (); - added_roots_queue = ReactiveFifo.create (); - edge_change_queue = ReactiveFifo.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 = ReactiveMap.create (); metrics = { @@ -443,11 +441,11 @@ let destroy t = ReactiveSet.destroy t.scratch_set_a; ReactiveSet.destroy t.scratch_set_b; ReactiveSet.destroy t.edge_has_new; - ReactiveFifo.destroy t.delete_queue; - ReactiveFifo.destroy t.rederive_queue; - ReactiveFifo.destroy t.expansion_queue; - ReactiveFifo.destroy t.added_roots_queue; - ReactiveFifo.destroy t.edge_change_queue; + 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; ReactiveSet.destroy t.metrics.scratch_reachable; ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave @@ -459,12 +457,10 @@ type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t let iter_current t f = - ReactiveSet.iter_with - (fun f k -> f (Offheap.unsafe_to_value k) ()) - f t.current + ReactiveSet.iter_with (fun f k -> f (Stable.unsafe_to_value k) ()) f t.current let get_current t k = - if ReactiveSet.mem t.current (off_key k) then Maybe.some () else Maybe.none + if ReactiveSet.mem t.current (stable_key k) then Maybe.some () else Maybe.none let current_length t = ReactiveSet.cardinal t.current @@ -475,7 +471,7 @@ let add_pred t ~target ~pred = ReactivePoolMapSet.add t.pred_map target pred let remove_pred t ~target ~pred = ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred -let has_live_pred_key t pred = ReactiveSet.mem t.current (off_key pred) +let has_live_pred_key t pred = ReactiveSet.mem t.current (stable_key pred) let has_live_predecessor t k = let r = ReactivePoolMapSet.find_maybe t.pred_map k in @@ -487,41 +483,41 @@ 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 r = ReactiveMap.find_maybe t.edge_map (off_key src) in + let r = ReactiveMap.find_maybe t.edge_map (stable_key src) in let old_successors = - if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in - if OffheapList.is_empty old_successors && OffheapList.is_empty new_successors - then ReactiveMap.remove t.edge_map (off_key src) - else if OffheapList.is_empty old_successors then ( - OffheapList.iter_with add_pred_for_src (t, src) new_successors; - ReactiveMap.replace t.edge_map (off_key src) new_successors) - else if OffheapList.is_empty new_successors then ( - OffheapList.iter_with remove_pred_for_src (t, src) old_successors; - ReactiveMap.remove t.edge_map (off_key src)) + if StableList.is_empty old_successors && StableList.is_empty new_successors + then ReactiveMap.remove t.edge_map (stable_key src) + else if StableList.is_empty old_successors then ( + StableList.iter_with add_pred_for_src (t, src) new_successors; + ReactiveMap.replace t.edge_map (stable_key src) new_successors) + else if StableList.is_empty new_successors then ( + StableList.iter_with remove_pred_for_src (t, src) old_successors; + ReactiveMap.remove t.edge_map (stable_key src)) else ( ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; - OffheapList.iter - (fun k -> ReactiveSet.add t.scratch_set_a (off_key k)) + StableList.iter + (fun k -> ReactiveSet.add t.scratch_set_a (stable_key k)) new_successors; - OffheapList.iter - (fun k -> ReactiveSet.add t.scratch_set_b (off_key k)) + StableList.iter + (fun k -> ReactiveSet.add t.scratch_set_b (stable_key k)) old_successors; - OffheapList.iter_with + StableList.iter_with (fun () target -> - if not (ReactiveSet.mem t.scratch_set_a (off_key target)) then + if not (ReactiveSet.mem t.scratch_set_a (stable_key target)) then remove_pred t ~target ~pred:src) () old_successors; - OffheapList.iter_with + StableList.iter_with (fun () target -> - if not (ReactiveSet.mem t.scratch_set_b (off_key target)) then + if not (ReactiveSet.mem t.scratch_set_b (stable_key target)) then add_pred t ~target ~pred:src) () new_successors; - ReactiveMap.replace t.edge_map (off_key src) new_successors) + ReactiveMap.replace t.edge_map (stable_key src) new_successors) let initialize t ~roots ~edges = ReactiveSet.clear t.roots; @@ -529,114 +525,108 @@ let initialize t ~roots ~edges = ReactivePoolMapSet.clear t.pred_map; ReactiveWave.iter roots (fun k _ -> ReactiveSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> - apply_edge_update t - ~src:(Offheap.unsafe_to_value k) - ~new_successors:(OffheapList.unsafe_of_offheap_list successors)); + apply_edge_update t ~src:(Stable.unsafe_to_value k) + ~new_successors:(StableList.of_stable_list successors)); recompute_current t let is_supported t k = - ReactiveSet.mem t.roots (off_key k) || has_live_predecessor t k + ReactiveSet.mem t.roots (stable_key k) || has_live_predecessor t k let old_successors t k = - let r = ReactiveMap.find_maybe t.old_successors_for_changed (off_key k) in + let r = ReactiveMap.find_maybe t.old_successors_for_changed (stable_key k) in if Maybe.is_some r then Maybe.unsafe_get r else - let r2 = ReactiveMap.find_maybe t.edge_map (off_key k) in - if Maybe.is_some r2 then Maybe.unsafe_get r2 else OffheapList.empty () + let r2 = ReactiveMap.find_maybe t.edge_map (stable_key k) in + if Maybe.is_some r2 then Maybe.unsafe_get r2 else StableList.empty () let mark_deleted t k = if - ReactiveSet.mem t.current (off_key k) - && not (ReactiveSet.mem t.deleted_nodes (off_key k)) + ReactiveSet.mem t.current (stable_key k) + && not (ReactiveSet.mem t.deleted_nodes (stable_key k)) then ( - ReactiveSet.add t.deleted_nodes (off_key k); + ReactiveSet.add t.deleted_nodes (stable_key k); enqueue t.delete_queue k) let enqueue_expand t k = if - ReactiveSet.mem t.current (off_key k) - && not (ReactiveSet.mem t.expansion_seen (off_key k)) + ReactiveSet.mem t.current (stable_key k) + && not (ReactiveSet.mem t.expansion_seen (stable_key k)) then ( - ReactiveSet.add t.expansion_seen (off_key k); + ReactiveSet.add t.expansion_seen (stable_key k); enqueue t.expansion_queue k) let add_live t k = - if not (ReactiveSet.mem t.current (off_key k)) then ( - ReactiveSet.add t.current (off_key k); - if not (ReactiveSet.mem t.deleted_nodes (off_key k)) then - ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k) - (Maybe.maybe_unit_to_offheap (Maybe.some ())); + if not (ReactiveSet.mem t.current (stable_key k)) then ( + ReactiveSet.add t.current (stable_key k); + if not (ReactiveSet.mem t.deleted_nodes (stable_key k)) then + ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + (Maybe.maybe_unit_to_stable (Maybe.some ())); enqueue_expand t k) let enqueue_rederive_if_needed t k = if - ReactiveSet.mem t.deleted_nodes (off_key k) - && (not (ReactiveSet.mem t.current (off_key k))) - && (not (ReactiveSet.mem t.rederive_pending (off_key k))) + ReactiveSet.mem t.deleted_nodes (stable_key k) + && (not (ReactiveSet.mem t.current (stable_key k))) + && (not (ReactiveSet.mem t.rederive_pending (stable_key k))) && is_supported t k then ( - ReactiveSet.add t.rederive_pending (off_key k); + ReactiveSet.add t.rederive_pending (stable_key k); enqueue t.rederive_queue k) let scan_root_entry t k mv = - let had_root = ReactiveSet.mem t.roots (off_key k) in + let had_root = ReactiveSet.mem t.roots (stable_key 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 set_add_k set k = ReactiveSet.add set (off_key k) +let set_add_k set k = ReactiveSet.add set (stable_key k) let mark_deleted_if_absent (t, set) k = - if not (ReactiveSet.mem set (off_key k)) then mark_deleted t k + if not (ReactiveSet.mem set (stable_key k)) then mark_deleted t k -let not_in_set set k = not (ReactiveSet.mem set (off_key k)) +let not_in_set set k = not (ReactiveSet.mem set (stable_key k)) let mark_deleted_unless_in_set t set xs = - OffheapList.iter_with mark_deleted_if_absent (t, set) xs + StableList.iter_with mark_deleted_if_absent (t, set) xs -let exists_not_in_set set xs = OffheapList.exists_with not_in_set 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 r = ReactiveMap.find_maybe t.edge_map (off_key src) in + let r = ReactiveMap.find_maybe t.edge_map (stable_key src) in let old_succs = - if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in let new_succs = - if Maybe.is_some mv then OffheapList.unsafe_of_list (Maybe.unsafe_get mv) - else OffheapList.empty () + if Maybe.is_some mv then Maybe.unsafe_get mv else StableList.empty () in - ReactiveMap.replace t.old_successors_for_changed (off_key src) old_succs; - ReactiveMap.replace t.new_successors_for_changed (off_key src) new_succs; + ReactiveMap.replace t.old_successors_for_changed (stable_key src) old_succs; + ReactiveMap.replace t.new_successors_for_changed (stable_key src) new_succs; enqueue t.edge_change_queue src; - let src_is_live = ReactiveSet.mem t.current (off_key src) in + let src_is_live = ReactiveSet.mem t.current (stable_key src) in match (old_succs, new_succs) with - | _ when OffheapList.is_empty old_succs && OffheapList.is_empty new_succs -> - () - | _ when OffheapList.is_empty old_succs -> - ReactiveSet.add t.edge_has_new (off_key src) - | _ when OffheapList.is_empty new_succs -> - if src_is_live then OffheapList.iter_with mark_deleted t old_succs + | _ when StableList.is_empty old_succs && StableList.is_empty new_succs -> () + | _ when StableList.is_empty old_succs -> + ReactiveSet.add t.edge_has_new (stable_key src) + | _ when StableList.is_empty new_succs -> + if src_is_live then StableList.iter_with mark_deleted t old_succs | _ -> ReactiveSet.clear t.scratch_set_a; ReactiveSet.clear t.scratch_set_b; - OffheapList.iter_with set_add_k t.scratch_set_a new_succs; - OffheapList.iter_with set_add_k t.scratch_set_b old_succs; + 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 - ReactiveSet.add t.edge_has_new (off_key src) + ReactiveSet.add t.edge_has_new (stable_key src) let apply_root_mutation t k mv = - if Maybe.is_some mv then ReactiveSet.add t.roots (off_key k) - else ReactiveSet.remove t.roots (off_key k) + if Maybe.is_some mv then ReactiveSet.add t.roots (stable_key k) + else ReactiveSet.remove t.roots (stable_key k) let emit_removal t k () = - if not (ReactiveSet.mem t.current (off_key k)) then - ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k) - Maybe.none_offheap + if not (ReactiveSet.mem t.current (stable_key k)) then + ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) Maybe.none_stable let rebuild_edge_change_queue t src _succs = - ReactiveFifo.push t.edge_change_queue src + StableQueue.push t.edge_change_queue src let remove_from_current t k = ReactiveSet.remove t.current k @@ -649,9 +639,9 @@ let apply_list t ~roots ~edges = in (* Clear all scratch state up front *) ReactiveSet.clear t.deleted_nodes; - ReactiveFifo.clear t.delete_queue; - ReactiveFifo.clear t.added_roots_queue; - ReactiveFifo.clear t.edge_change_queue; + StableQueue.clear t.delete_queue; + StableQueue.clear t.added_roots_queue; + StableQueue.clear t.edge_change_queue; ReactiveMap.clear t.old_successors_for_changed; ReactiveMap.clear t.new_successors_for_changed; ReactiveSet.clear t.edge_has_new; @@ -662,16 +652,20 @@ let apply_list t ~roots ~edges = buffer added roots for later expansion *) ReactiveWave.iter_with roots (fun t k mv -> - scan_root_entry t (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value mv)) + scan_root_entry t (Stable.unsafe_to_value k) (Stable.unsafe_to_value mv)) t; (* Phase 1b: scan edge entries — seed delete queue for removed targets, store new_succs and has_new_edge for later phases *) ReactiveWave.iter_with edges (fun t src mv -> - scan_edge_entry t - (Offheap.unsafe_to_value src) - (Offheap.unsafe_to_value mv)) + let mv = Stable.unsafe_to_value mv in + let mv = + if Maybe.is_some mv then + Maybe.some (StableList.unsafe_of_list (Maybe.unsafe_get mv)) + else Maybe.none + in + scan_edge_entry t (Stable.unsafe_to_value src) mv) t; Invariants.assert_edge_has_new_consistent @@ -681,14 +675,13 @@ let apply_list t ~roots ~edges = ~edge_has_new:t.edge_has_new; (* Phase 2: delete BFS *) - while not (ReactiveFifo.is_empty t.delete_queue) do - let k = Offheap.unsafe_to_value (ReactiveFifo.pop t.delete_queue) in + while not (StableQueue.is_empty t.delete_queue) do + let k = Stable.unsafe_to_value (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 + OffheapList.length succs); - OffheapList.iter_with mark_deleted t succs + m.delete_edges_scanned <- m.delete_edges_scanned + StableList.length succs); + StableList.iter_with mark_deleted t succs done; if Invariants.enabled then Invariants.assert_deleted_nodes_closed ~current:t.current @@ -697,20 +690,19 @@ let apply_list t ~roots ~edges = (* Phase 3: apply root and edge mutations *) ReactiveWave.iter_with roots (fun t k mv -> - apply_root_mutation t - (Offheap.unsafe_to_value k) - (Offheap.unsafe_to_value mv)) + apply_root_mutation t (Stable.unsafe_to_value k) + (Stable.unsafe_to_value mv)) t; (* Apply edge updates by draining edge_change_queue. *) - while not (ReactiveFifo.is_empty t.edge_change_queue) do - let src = ReactiveFifo.pop t.edge_change_queue in + while not (StableQueue.is_empty t.edge_change_queue) do + let src = StableQueue.pop t.edge_change_queue in let r = ReactiveMap.find_maybe t.new_successors_for_changed src in let new_succs = - if Maybe.is_some r then Maybe.unsafe_get r else OffheapList.empty () + if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in apply_edge_update t - ~src:(Offheap.unsafe_to_value src) + ~src:(Stable.unsafe_to_value src) ~new_successors:new_succs done; (* Rebuild edge_change_queue from new_successors_for_changed keys for @@ -725,21 +717,21 @@ let apply_list t ~roots ~edges = | None -> ()); (* Phase 4: rederive *) - ReactiveFifo.clear t.rederive_queue; + StableQueue.clear t.rederive_queue; ReactiveSet.clear t.rederive_pending; ReactiveSet.iter_with - (fun t k -> enqueue_rederive_if_needed_kv t (Offheap.unsafe_to_value k)) + (fun t k -> enqueue_rederive_if_needed_kv t (Stable.unsafe_to_value k)) t t.deleted_nodes; - while not (ReactiveFifo.is_empty t.rederive_queue) do - let k = ReactiveFifo.pop t.rederive_queue in + 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; ReactiveSet.remove t.rederive_pending k; if ReactiveSet.mem t.deleted_nodes k && (not (ReactiveSet.mem t.current k)) - && is_supported t (Offheap.unsafe_to_value k) + && is_supported t (Stable.unsafe_to_value k) then ( ReactiveSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; @@ -748,50 +740,49 @@ let apply_list t ~roots ~edges = let succs = Maybe.unsafe_get r in if Metrics.enabled then m.rederive_edges_scanned <- - m.rederive_edges_scanned + OffheapList.length succs; - OffheapList.iter_with enqueue_rederive_if_needed t succs)) + m.rederive_edges_scanned + StableList.length succs; + StableList.iter_with enqueue_rederive_if_needed t succs)) done; if Invariants.enabled then Invariants.assert_no_supported_deleted_left ~deleted_nodes:t.deleted_nodes ~current:t.current ~supported:(is_supported t); (* Phase 5: expansion *) - ReactiveFifo.clear t.expansion_queue; + StableQueue.clear t.expansion_queue; ReactiveSet.clear t.expansion_seen; (* Seed expansion from added roots *) - while not (ReactiveFifo.is_empty t.added_roots_queue) do - add_live t (Offheap.unsafe_to_value (ReactiveFifo.pop t.added_roots_queue)) + while not (StableQueue.is_empty t.added_roots_queue) do + add_live t (Stable.unsafe_to_value (StableQueue.pop t.added_roots_queue)) done; (* Seed expansion from edge changes with new edges *) - while not (ReactiveFifo.is_empty t.edge_change_queue) do - let src = ReactiveFifo.pop t.edge_change_queue in + while not (StableQueue.is_empty t.edge_change_queue) do + let src = StableQueue.pop t.edge_change_queue in if ReactiveSet.mem t.current src && ReactiveSet.mem t.edge_has_new src then - enqueue_expand t (Offheap.unsafe_to_value src) + enqueue_expand t (Stable.unsafe_to_value src) done; - while not (ReactiveFifo.is_empty t.expansion_queue) do - let k = ReactiveFifo.pop t.expansion_queue in + 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 = ReactiveMap.find_maybe t.edge_map k in if Maybe.is_some r then ( let succs = Maybe.unsafe_get r in if Metrics.enabled then m.expansion_edges_scanned <- - m.expansion_edges_scanned + OffheapList.length succs; - OffheapList.iter_with add_live t succs) + m.expansion_edges_scanned + StableList.length succs; + StableList.iter_with add_live t succs) done; ReactiveSet.iter_with - (fun t k -> emit_removal t (Offheap.unsafe_to_value k) ()) + (fun t k -> emit_removal t (Stable.unsafe_to_value k) ()) t t.deleted_nodes; let output_entries_list = if Invariants.enabled then ( let entries = ref [] in ReactiveWave.iter t.output_wave (fun k v_opt -> entries := - (Offheap.unsafe_to_value k, Offheap.unsafe_to_value v_opt) - :: !entries); + (Stable.unsafe_to_value k, Stable.unsafe_to_value v_opt) :: !entries); !entries) else [] in diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 7250fa25a54..7ed87ccecc9 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -7,27 +7,27 @@ open TestHelpers let words_since = AllocMeasure.words_since -let off = Offheap.unsafe_of_value -let off_int = Offheap.int -let off_unit = Offheap.unit -let off_maybe_int = Maybe.maybe_int_to_offheap -let off_maybe_unit = Maybe.maybe_unit_to_offheap +let stable = Stable.unsafe_of_value +let stable_int = Stable.int +let stable_unit = Stable.unit +let stable_maybe_int = Maybe.maybe_int_to_stable +let stable_maybe_unit = Maybe.maybe_unit_to_stable -let unsafe_wave_push wave k v = ReactiveWave.push wave (off k) (off v) +let unsafe_wave_push wave k v = ReactiveWave.push wave (stable k) (stable v) -let print_offheap_usage () = +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 " offheap: blocks=%d slots=%d bytes=%d\n" blocks slots bytes + Printf.printf " stable: blocks=%d slots=%d bytes=%d\n" blocks slots bytes -let reset_offheap_state () = +let reset_stable_state () = Reactive.reset (); Allocator.reset (); assert (Allocator.live_block_count () = 0); assert (Allocator.live_block_capacity_slots () = 0) -let print_offheap_snapshot label = +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 @@ -46,16 +46,16 @@ let test_fixpoint_alloc_n n = let state = ReactiveFixpoint.create ~max_nodes:n ~max_edges:n in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) - ReactiveWave.push root_snap (off_int 0) (off_unit ()); + ReactiveWave.push root_snap (stable_int 0) (stable_unit ()); for i = 0 to n - 2 do - ReactiveWave.push edge_snap (off_int i) (Offheap.of_value edge_values.(i)) + ReactiveWave.push edge_snap (stable_int i) (Stable.of_value edge_values.(i)) done; ReactiveFixpoint.initialize state ~roots:root_snap ~edges:edge_snap; assert (ReactiveFixpoint.current_length state = n); (* Pre-build waves once *) - ReactiveWave.push remove_root (off_int 0) Maybe.none_offheap; - ReactiveWave.push add_root (off_int 0) (off_maybe_unit (Maybe.some ())); + ReactiveWave.push remove_root (stable_int 0) Maybe.none_stable; + ReactiveWave.push add_root (stable_int 0) (stable_maybe_unit (Maybe.some ())); (* Warmup *) for _ = 1 to 5 do @@ -81,14 +81,14 @@ let test_fixpoint_alloc_n n = words_since () / iters let test_fixpoint_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- FlatMap allocation ---- *) @@ -100,7 +100,7 @@ let test_flatmap_alloc_n n = (* Populate: n entries *) for i = 0 to n - 1 do - ReactiveFlatMap.push state (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveFlatMap.push state (stable_int i) (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n); @@ -108,12 +108,13 @@ let test_flatmap_alloc_n 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 (off i) Maybe.none_offheap + ReactiveFlatMap.push state (stable 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 (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveFlatMap.push state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n) @@ -124,11 +125,12 @@ let test_flatmap_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveFlatMap.push state (off i) Maybe.none_offheap + ReactiveFlatMap.push state (stable i) Maybe.none_stable done; ignore (ReactiveFlatMap.process state); for i = 0 to n - 1 do - ReactiveFlatMap.push state (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveFlatMap.push state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveFlatMap.process state) done; @@ -137,14 +139,14 @@ let test_flatmap_alloc_n n = words_since () / iters let test_flatmap_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- Union allocation ---- *) @@ -154,7 +156,8 @@ let test_union_alloc_n n = (* Populate: n entries on the left side *) for i = 0 to n - 1 do - ReactiveUnion.push_left state (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveUnion.push_left state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n); @@ -162,12 +165,13 @@ let test_union_alloc_n 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 (off i) Maybe.none_offheap + ReactiveUnion.push_left state (stable 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 (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveUnion.push_left state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n) @@ -178,11 +182,12 @@ let test_union_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveUnion.push_left state (off i) Maybe.none_offheap + ReactiveUnion.push_left state (stable i) Maybe.none_stable done; ignore (ReactiveUnion.process state); for i = 0 to n - 1 do - ReactiveUnion.push_left state (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveUnion.push_left state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveUnion.process state) done; @@ -191,14 +196,14 @@ let test_union_alloc_n n = words_since () / iters let test_union_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- Join allocation ---- *) @@ -219,7 +224,8 @@ let test_join_alloc_n n = ReactiveHash.Map.replace right_tbl i (i * 10) done; for i = 0 to n - 1 do - ReactiveJoin.push_left state (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveJoin.push_left state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n); @@ -227,12 +233,13 @@ let test_join_alloc_n n = (* Warmup: toggle all left entries *) for _ = 1 to 5 do for i = 0 to n - 1 do - ReactiveJoin.push_left state (off i) Maybe.none_offheap + ReactiveJoin.push_left state (stable 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 (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveJoin.push_left state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n) @@ -243,11 +250,12 @@ let test_join_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveJoin.push_left state (off i) Maybe.none_offheap + ReactiveJoin.push_left state (stable i) Maybe.none_stable done; ignore (ReactiveJoin.process state); for i = 0 to n - 1 do - ReactiveJoin.push_left state (off_int i) (off_maybe_int (Maybe.some i)) + ReactiveJoin.push_left state (stable_int i) + (stable_maybe_int (Maybe.some i)) done; ignore (ReactiveJoin.process state) done; @@ -256,14 +264,14 @@ let test_join_alloc_n n = words_since () / iters let test_join_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- Reactive.join end-to-end allocation ---- *) @@ -294,7 +302,7 @@ let test_reactive_join_alloc_n n = (* Pre-build waves for the hot loop: toggle all left entries *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (off i) Maybe.none_offheap + ReactiveWave.push remove_wave (stable i) Maybe.none_stable done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do @@ -324,14 +332,14 @@ let test_reactive_join_alloc_n n = words_since () / iters let test_reactive_join_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- Reactive.fixpoint end-to-end allocation ---- *) @@ -340,7 +348,7 @@ 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_offheap = Array.map OffheapList.of_list edge_values in + 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 @@ -348,8 +356,8 @@ let test_reactive_fixpoint_alloc_n n = let edge_wave = ReactiveWave.create ~max_entries:(max 1 (n - 1)) () in ReactiveWave.clear edge_wave; for i = 0 to n - 2 do - ReactiveWave.push edge_wave (off_int i) - (Maybe.maybe_offheap_list_to_offheap (Maybe.some edge_values_offheap.(i))) + ReactiveWave.push edge_wave (stable_int i) + (Maybe.maybe_stable_list_to_stable (Maybe.some edge_values_stable.(i))) done; emit_edges edge_wave; let reachable = Reactive.Fixpoint.create ~name:"reachable" ~init ~edges () in @@ -360,9 +368,9 @@ let test_reactive_fixpoint_alloc_n n = (* Pre-build waves for the hot loop *) let remove_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push remove_wave (off_int 0) Maybe.none_offheap; + ReactiveWave.push remove_wave (stable_int 0) Maybe.none_stable; let add_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push add_wave (off_int 0) (off_maybe_unit (Maybe.some ())); + ReactiveWave.push add_wave (stable_int 0) (stable_maybe_unit (Maybe.some ())); (* Warmup *) for _ = 1 to 5 do @@ -387,14 +395,14 @@ let test_reactive_fixpoint_alloc_n n = words_since () / iters let test_reactive_fixpoint_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- Reactive.union end-to-end allocation ---- *) @@ -415,7 +423,7 @@ let test_reactive_union_alloc_n n = (* Pre-build waves: single wave with all n entries *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (off i) Maybe.none_offheap + ReactiveWave.push remove_wave (stable i) Maybe.none_stable done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do @@ -445,14 +453,14 @@ let test_reactive_union_alloc_n n = words_since () / iters let test_reactive_union_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- Reactive.flatMap end-to-end allocation ---- *) @@ -474,7 +482,7 @@ let test_reactive_flatmap_alloc_n n = (* Pre-build waves *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (off i) Maybe.none_offheap + ReactiveWave.push remove_wave (stable i) Maybe.none_stable done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do @@ -503,14 +511,14 @@ let test_reactive_flatmap_alloc_n n = words_since () / iters let test_reactive_flatmap_alloc () = - reset_offheap_state (); + 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) [10; 100; 1000]; - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- PoolMapSet allocation ---- *) @@ -525,7 +533,7 @@ let count_pool_empty_sets pms = s let test_pool_map_set_pattern_drain_key_churn () = - reset_offheap_state (); + reset_stable_state (); Printf.printf "=== Test: PoolMapSet pattern (drain_key churn) ===\n"; let n = 100 in let iters = 100 in @@ -558,11 +566,11 @@ let test_pool_map_set_pattern_drain_key_churn () = assert (ReactivePoolMapSet.cardinal pms = n); assert (st.empty = 0); assert (miss_delta = 0); - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" let test_pool_map_set_pattern_remove_recycle_churn () = - reset_offheap_state (); + reset_stable_state (); Printf.printf "=== Test: PoolMapSet pattern (remove_from_set_and_recycle_if_empty churn) \ ===\n"; @@ -599,7 +607,7 @@ let test_pool_map_set_pattern_remove_recycle_churn () = assert (ReactivePoolMapSet.cardinal pms = n); assert (st.empty = 0); assert (miss_delta = 0); - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" (* ---- PoolMapMap allocation ---- *) @@ -615,7 +623,7 @@ let count_empty_inner_maps pmm ~start ~count = s let test_pool_map_map_pattern_drain_outer_churn () = - reset_offheap_state (); + reset_stable_state (); Printf.printf "=== Test: PoolMapMap pattern (drain_outer churn) ===\n"; let n = 100 in let iters = 100 in @@ -649,11 +657,11 @@ let test_pool_map_map_pattern_drain_outer_churn () = assert (ReactivePoolMapMap.outer_cardinal pmm = n); assert (st.empty = 0); assert (miss_delta = 0); - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" let test_pool_map_map_pattern_remove_recycle_churn () = - reset_offheap_state (); + reset_stable_state (); Printf.printf "=== Test: PoolMapMap pattern (remove_from_inner_and_recycle_if_empty \ churn) ===\n"; @@ -691,7 +699,7 @@ let test_pool_map_map_pattern_remove_recycle_churn () = assert (ReactivePoolMapMap.outer_cardinal pmm = n); assert (st.empty = 0); assert (miss_delta = 0); - print_offheap_usage (); + print_stable_usage (); Printf.printf "PASSED\n\n" let run_all () = diff --git a/analysis/reactive/test/TableTest.ml b/analysis/reactive/test/TableTest.ml index b3b33ec768a..56f45bd8dc7 100644 --- a/analysis/reactive/test/TableTest.ml +++ b/analysis/reactive/test/TableTest.ml @@ -1,4 +1,4 @@ -(** Tests for off-heap ReactiveTable storage. *) +(** Tests for stable ReactiveTable storage. *) let test_table_promoted_wave_lifecycle () = Printf.printf "=== Test: table promoted-wave lifecycle ===\n"; @@ -38,20 +38,20 @@ let test_table_promoted_wave_lifecycle () = ignore (AllocMeasure.words_since ()); ReactiveTable.clear t; for i = 0 to count - 1 do - ReactiveTable.push t (Offheap.of_value fresh.(i)) + ReactiveTable.push t (Stable.of_value fresh.(i)) done; assert (ReactiveTable.length t = count); assert (ReactiveTable.capacity t >= ReactiveTable.length t); - ReactiveTable.set t 0 (Offheap.of_value fresh.(count - 1)); - assert (Offheap.unsafe_to_value (ReactiveTable.get t 0) == fresh.(count - 1)); + ReactiveTable.set t 0 (Stable.of_value fresh.(count - 1)); + assert (Stable.unsafe_to_value (ReactiveTable.get t 0) == fresh.(count - 1)); for i = 0 to count - 1 do let expected = if i = 0 then fresh.(count - 1) else fresh.(i) in - let recovered = Offheap.unsafe_to_value (ReactiveTable.get t i) in + let recovered = Stable.unsafe_to_value (ReactiveTable.get t i) in assert (recovered == expected); assert (Bytes.get recovered 0 = Bytes.get expected 0); assert (Bytes.get recovered (width - 1) = Bytes.get expected (width - 1)) done; - assert (Offheap.unsafe_to_value (ReactiveTable.pop t) == fresh.(count - 1)); + assert (Stable.unsafe_to_value (ReactiveTable.pop t) == fresh.(count - 1)); assert (ReactiveTable.length t = count - 1); ReactiveTable.shrink_to_fit t; assert (ReactiveTable.capacity t = ReactiveTable.length t); @@ -84,13 +84,13 @@ let test_table_unsafe_minor_heap_demo () = let width = 64 in let t = ReactiveTable.create ~initial_capacity:count in (* Each [Bytes.make] result starts in the minor heap. We store only the raw - addresses off-heap and intentionally drop all OCaml roots. *) + addresses in stable storage and intentionally drop all OCaml roots. *) for i = 0 to count - 1 do let c = Char.chr ((i mod 26) + Char.code 'A') in let fresh = Bytes.make width c in Bytes.set fresh 0 c; Bytes.set fresh (width - 1) c; - ReactiveTable.push t (Offheap.unsafe_of_value fresh) + ReactiveTable.push t (Stable.unsafe_of_value fresh) done; Gc.compact (); for round = 1 to 200 do @@ -101,14 +101,14 @@ let test_table_unsafe_minor_heap_demo () = Gc.compact () done; Printf.printf - "About to validate %d minor-heap values stored off-heap. This is unsafe \ - and may return garbage or crash.\n" + "About to validate %d minor-heap values stored in stable storage. This \ + is unsafe and may return garbage or crash.\n" count; let mismatches = ref 0 in let samples = ref [] in for i = 0 to count - 1 do let expected = Char.chr ((i mod 26) + Char.code 'A') in - let recovered : bytes = Offheap.unsafe_to_value (ReactiveTable.get t i) in + let recovered : bytes = Stable.unsafe_to_value (ReactiveTable.get t i) in let ok = Bytes.length recovered = width && Bytes.get recovered 0 = expected From ccbc982f220b8cfa179be0ae4d2eba784289bca8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 08:20:27 +0100 Subject: [PATCH 27/54] analysis/reactive: rename offheap to stable --- analysis/reactive/src/Allocator.ml | 16 +-- analysis/reactive/src/Allocator.mli | 24 ++-- .../reactive/src/CONVERTING_COMBINATORS.md | 6 +- analysis/reactive/src/Maybe.ml | 16 +-- analysis/reactive/src/Maybe.mli | 18 +-- analysis/reactive/src/Offheap.mli | 25 ----- analysis/reactive/src/Reactive.ml | 21 ++-- .../reactive/src/ReactiveFileCollection.ml | 16 +-- analysis/reactive/src/ReactiveFixpoint.mli | 2 +- analysis/reactive/src/ReactiveFlatMap.ml | 36 +++--- analysis/reactive/src/ReactiveFlatMap.mli | 4 +- analysis/reactive/src/ReactiveJoin.ml | 68 +++++------ analysis/reactive/src/ReactiveJoin.mli | 10 +- analysis/reactive/src/ReactiveMap.ml | 28 ++--- analysis/reactive/src/ReactiveMap.mli | 14 +-- analysis/reactive/src/ReactiveSet.ml | 20 ++-- analysis/reactive/src/ReactiveSet.mli | 12 +- analysis/reactive/src/ReactiveTable.ml | 8 +- analysis/reactive/src/ReactiveTable.mli | 16 +-- analysis/reactive/src/ReactiveUnion.ml | 106 ++++++++---------- analysis/reactive/src/ReactiveUnion.mli | 6 +- analysis/reactive/src/ReactiveWave.ml | 6 +- analysis/reactive/src/ReactiveWave.mli | 16 +-- .../reactive/src/{Offheap.ml => Stable.ml} | 2 +- analysis/reactive/src/Stable.mli | 25 +++++ .../src/{OffheapList.ml => StableList.ml} | 12 +- .../src/{OffheapList.mli => StableList.mli} | 12 +- .../src/{ReactiveFifo.ml => StableQueue.ml} | 4 +- .../src/{ReactiveFifo.mli => StableQueue.mli} | 8 +- analysis/reactive/src/dune | 2 +- analysis/reactive/test/GlitchFreeTest.ml | 4 +- analysis/reactive/test/TestHelpers.ml | 45 ++++---- 32 files changed, 292 insertions(+), 316 deletions(-) delete mode 100644 analysis/reactive/src/Offheap.mli rename analysis/reactive/src/{Offheap.ml => Stable.ml} (80%) create mode 100644 analysis/reactive/src/Stable.mli rename analysis/reactive/src/{OffheapList.ml => StableList.ml} (76%) rename analysis/reactive/src/{OffheapList.mli => StableList.mli} (61%) rename analysis/reactive/src/{ReactiveFifo.ml => StableQueue.ml} (93%) rename analysis/reactive/src/{ReactiveFifo.mli => StableQueue.mli} (68%) diff --git a/analysis/reactive/src/Allocator.ml b/analysis/reactive/src/Allocator.ml index 2353d9704e9..7e29a2d4010 100644 --- a/analysis/reactive/src/Allocator.ml +++ b/analysis/reactive/src/Allocator.ml @@ -32,11 +32,11 @@ module Block = struct = "caml_reactive_allocator_resize" [@@noalloc] - external unsafe_get : 'a t -> int -> 'a Offheap.t + external unsafe_get : 'a t -> int -> 'a Stable.t = "caml_reactive_allocator_get" [@@noalloc] - external unsafe_set : 'a t -> int -> 'a Offheap.t -> unit + external unsafe_set : 'a t -> int -> 'a Stable.t -> unit = "caml_reactive_allocator_set" [@@noalloc] @@ -80,17 +80,17 @@ module Block2 = struct let create ~capacity ~x0 ~y0 = let t = Block.create ~capacity:(capacity + header_slots) in - Block.set t 0 (Offheap.unsafe_of_value x0); - Block.set t 1 (Offheap.unsafe_of_value y0); + 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 = Offheap.unsafe_to_value (Block.get t 0) - let set0 t x = Block.set t 0 (Offheap.unsafe_of_value x) - let get1 t = Offheap.unsafe_to_value (Block.get t 1) - let set1 t y = Block.set t 1 (Offheap.unsafe_of_value y) + let get0 t = Stable.unsafe_to_value (Block.get t 0) + let set0 t x = Block.set t 0 (Stable.unsafe_of_value x) + let get1 t = Stable.unsafe_to_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 diff --git a/analysis/reactive/src/Allocator.mli b/analysis/reactive/src/Allocator.mli index 1481be2c773..3af9ef0e675 100644 --- a/analysis/reactive/src/Allocator.mli +++ b/analysis/reactive/src/Allocator.mli @@ -1,7 +1,7 @@ -(** Off-heap storage for raw OCaml values. +(** Stable storage for raw OCaml values. Main concepts: - - A [block] is an off-heap buffer managed by the allocator. + - 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. @@ -11,14 +11,14 @@ - is not in the minor heap, and - remains reachable through ordinary OCaml roots elsewhere. - Immediates such as [int] are always safe to store. Use {!Offheap} to mark - values that cross into off-heap containers. *) + 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 an off-heap block of raw OCaml value slots. *) + (** 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. *) @@ -29,11 +29,11 @@ module Block : sig val resize : 'a t -> capacity:int -> unit (** Resize the block, preserving the prefix up to the new capacity. *) - val get : 'a t -> int -> 'a Offheap.t + 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 off-heap. *) + alive and out of the minor heap while stored stable. *) - val set : 'a t -> int -> 'a Offheap.t -> unit + val set : 'a t -> int -> 'a Stable.t -> unit (** Write a slot. *) val blit : @@ -45,7 +45,7 @@ module Block2 : sig type ('a, 'x, 'y) t val create : capacity:int -> x0:'x -> y0:'y -> ('a, 'x, 'y) t - (** Allocate an off-heap block with two typed header slots followed by + (** Allocate a stable block with two typed header slots followed by [capacity] data slots. *) val destroy : ('a, 'x, 'y) t -> unit @@ -63,10 +63,10 @@ module Block2 : sig val get1 : ('a, 'x, 'y) t -> 'y val set1 : ('a, 'x, 'y) t -> 'y -> unit - val get : ('a, 'x, 'y) t -> int -> 'a Offheap.t + val get : ('a, 'x, 'y) t -> int -> 'a Stable.t (** Read a data slot. *) - val set : ('a, 'x, 'y) t -> int -> 'a Offheap.t -> unit + val set : ('a, 'x, 'y) t -> int -> 'a Stable.t -> unit (** Write a data slot. *) val blit : @@ -96,5 +96,5 @@ val reset : unit -> unit 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 off-heap storage + 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 index 873b64336f1..dc132bbe225 100644 --- a/analysis/reactive/src/CONVERTING_COMBINATORS.md +++ b/analysis/reactive/src/CONVERTING_COMBINATORS.md @@ -156,9 +156,9 @@ 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 `ReactiveFifo` for BFS/worklist patterns +### Use `StableQueue` for BFS/worklist patterns -Off-heap FIFOs (`ReactiveFifo`) eliminate cons-cell +Stable FIFOs (`StableQueue`) eliminate cons-cell allocation from worklist patterns. Clear + push cycles reuse the backing array at steady state. @@ -337,7 +337,7 @@ Converted to `ReactiveHash`: - 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 `ReactiveFifo` (off-heap FIFO): +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 diff --git a/analysis/reactive/src/Maybe.ml b/analysis/reactive/src/Maybe.ml index dc4c3daf506..b27c7181e11 100644 --- a/analysis/reactive/src/Maybe.ml +++ b/analysis/reactive/src/Maybe.ml @@ -10,20 +10,20 @@ let sentinel_words = 257 let sentinel : Obj.t = Obj.repr (Array.make sentinel_words 0) let none = sentinel -let none_offheap = Offheap.of_value none +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] maybe_int_to_offheap (x : int t) : int t Offheap.t = - Offheap.unsafe_of_value x +let[@inline] maybe_int_to_stable (x : int t) : int t Stable.t = + Stable.unsafe_of_value x -let[@inline] maybe_unit_to_offheap (x : unit t) : unit t Offheap.t = - Offheap.unsafe_of_value x +let[@inline] maybe_unit_to_stable (x : unit t) : unit t Stable.t = + Stable.unsafe_of_value x -let[@inline] maybe_offheap_list_to_offheap (x : 'a OffheapList.t t) : - 'a list t Offheap.t = - Offheap.unsafe_of_value x +let[@inline] maybe_stable_list_to_stable (x : 'a StableList.t t) : + 'a list t Stable.t = + Stable.unsafe_of_value x let[@inline] to_option (x : 'a t) : 'a option = if x != sentinel then Some (Obj.obj x) else None diff --git a/analysis/reactive/src/Maybe.mli b/analysis/reactive/src/Maybe.mli index b270f863d3d..864d9c1b5c8 100644 --- a/analysis/reactive/src/Maybe.mli +++ b/analysis/reactive/src/Maybe.mli @@ -12,8 +12,8 @@ type 'a t val none : 'a t (** Unique sentinel representing the absent case. *) -val none_offheap : 'a t Offheap.t -(** Off-heap-marked form of [none]. Safe because the sentinel is allocated +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 @@ -21,14 +21,14 @@ val is_none : 'a t -> bool val is_some : 'a t -> bool val unsafe_get : 'a t -> 'a -val maybe_int_to_offheap : int t -> int t Offheap.t -(** Safely mark an [int] maybe value as suitable for off-heap storage. *) +val maybe_int_to_stable : int t -> int t Stable.t +(** Safely mark an [int] maybe value as suitable for stable storage. *) -val maybe_unit_to_offheap : unit t -> unit t Offheap.t -(** Safely mark a [unit] maybe value as suitable for off-heap storage. *) +val maybe_unit_to_stable : unit t -> unit t Stable.t +(** Safely mark a [unit] maybe value as suitable for stable storage. *) -val maybe_offheap_list_to_offheap : 'a OffheapList.t t -> 'a list t Offheap.t -(** Mark a maybe value carrying an already offheap-marked list as suitable for - storage in an off-heap container with semantic payload type ['a list]. *) +val maybe_stable_list_to_stable : 'a StableList.t t -> 'a list t Stable.t +(** Mark a maybe value carrying an already stable-marked list as suitable for + storage in a stable container with semantic payload type ['a list]. *) val to_option : 'a t -> 'a option diff --git a/analysis/reactive/src/Offheap.mli b/analysis/reactive/src/Offheap.mli deleted file mode 100644 index 0f1096bc4c7..00000000000 --- a/analysis/reactive/src/Offheap.mli +++ /dev/null @@ -1,25 +0,0 @@ -(** Values marked for storage in off-heap containers. - - This type does not prove safety. It marks values that are crossing the - off-heap boundary so call sites can be audited explicitly. *) - -type 'a t - -val unsafe_of_value : 'a -> 'a t -(** Unsafely mark a value as suitable for off-heap storage. The caller must - ensure the off-heap invariants hold. *) - -val of_value : 'a -> 'a t -(** Safely mark a value as suitable for off-heap 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 off-heap storage. *) - -val unit : unit -> unit t -(** Safely mark [()] as suitable for off-heap storage. *) - -val unsafe_to_value : 'a t -> 'a -(** Unsafely recover a regular OCaml value from an off-heap-marked value. *) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 2a2433aef99..09e7ba3744f 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -472,7 +472,7 @@ let level t = t.level let name t = t.name let unsafe_wave_push wave k v = - ReactiveWave.push wave (Offheap.unsafe_of_value k) (Offheap.unsafe_of_value v) + ReactiveWave.push wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value v) (** {1 Source Collection} *) @@ -483,8 +483,8 @@ module Source = struct } let apply_emit (tables : ('k, 'v) tables) k mv = - let k = Offheap.unsafe_to_value k in - let mv = Offheap.unsafe_to_value mv in + let k = Stable.unsafe_to_value k in + let mv = Stable.unsafe_to_value mv in if Maybe.is_some mv then ( let v = Maybe.unsafe_get mv in ReactiveHash.Map.replace tables.tbl k v; @@ -798,9 +798,8 @@ end module Fixpoint = struct let unsafe_wave_map_replace pending k v = - ReactiveHash.Map.replace pending - (Offheap.unsafe_to_value k) - (Offheap.unsafe_to_value v) + ReactiveHash.Map.replace pending (Stable.unsafe_to_value k) + (Stable.unsafe_to_value v) let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = @@ -858,9 +857,8 @@ module Fixpoint = struct ReactiveHash.Map.iter_with unsafe_wave_push root_wave root_pending; ReactiveHash.Map.iter_with (fun wave k mv -> - ReactiveWave.push wave - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value mv)) + ReactiveWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value mv)) edge_wave edge_pending; ReactiveHash.Map.clear root_pending; ReactiveHash.Map.clear edge_pending; @@ -917,9 +915,8 @@ module Fixpoint = struct ReactiveWave.clear init_edges_wave; init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); edges.iter (fun k succs -> - ReactiveWave.push init_edges_wave - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value succs)); + ReactiveWave.push init_edges_wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value succs)); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; ReactiveWave.destroy init_roots_wave; diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index 6ef2ac061c7..51c22cbc89a 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -42,8 +42,8 @@ let to_collection t : (string, 'v) Reactive.t = t.collection let emit_set t path value = ReactiveWave.clear t.scratch_wave; ReactiveWave.push t.scratch_wave - (Offheap.unsafe_of_value path) - (Offheap.unsafe_of_value (Maybe.some value)); + (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. *) @@ -78,8 +78,8 @@ let process_files_batch t paths = let value = t.internal.process path raw in Hashtbl.replace t.internal.cache path (new_id, value); ReactiveWave.push t.scratch_wave - (Offheap.unsafe_of_value path) - (Offheap.unsafe_of_value (Maybe.some value)); + (Stable.unsafe_of_value path) + (Stable.unsafe_of_value (Maybe.some value)); incr count) paths; if !count > 0 then t.emit t.scratch_wave; @@ -90,8 +90,8 @@ let remove t path = Hashtbl.remove t.internal.cache path; ReactiveWave.clear t.scratch_wave; ReactiveWave.push t.scratch_wave - (Offheap.unsafe_of_value path) - Maybe.none_offheap; + (Stable.unsafe_of_value path) + Maybe.none_stable; t.emit t.scratch_wave (** Remove multiple files as a batch *) @@ -103,8 +103,8 @@ let remove_batch t paths = if Hashtbl.mem t.internal.cache path then ( Hashtbl.remove t.internal.cache path; ReactiveWave.push t.scratch_wave - (Offheap.unsafe_of_value path) - Maybe.none_offheap; + (Stable.unsafe_of_value path) + Maybe.none_stable; incr count)) paths; if !count > 0 then t.emit t.scratch_wave; diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 22fb61e9092..05e9383335c 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -15,7 +15,7 @@ val create : max_nodes:int -> max_edges:int -> 'k t Raises [Invalid_argument] if capacities are not positive. *) val destroy : 'k t -> unit -(** Release fixpoint-owned off-heap storage. The state must not be used +(** Release fixpoint-owned stable storage. The state must not be used afterwards. *) val output_wave : 'k t -> 'k output_wave diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 1f0efded313..085a03eacda 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -35,15 +35,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveSet.add t.affected (Offheap.unsafe_of_value k2) + ReactiveSet.add t.affected (Stable.unsafe_of_value k2) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; ReactiveMap.replace t.target - (Offheap.unsafe_of_value k2) - (Offheap.unsafe_of_value v2) + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value v2) let create ~f ~merge = let rec t = @@ -87,7 +87,7 @@ let push t k v_opt = ReactiveMap.replace t.scratch k v_opt let remove_one_contribution (t : (_, _, _, _) t) k2 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 t.current_k1; - ReactiveSet.add t.affected (Offheap.unsafe_of_value k2) + ReactiveSet.add t.affected (Stable.unsafe_of_value k2) let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; @@ -101,27 +101,27 @@ let merge_one_contribution (t : (_, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _) t) k2 = - let k2 = Offheap.unsafe_to_value k2 in + let k2 = Stable.unsafe_to_value k2 in if ReactivePoolMapMap.inner_cardinal t.contributions k2 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; ReactiveMap.replace t.target - (Offheap.unsafe_of_value k2) - (Offheap.unsafe_of_value t.merge_acc); + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value t.merge_acc); ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k2) - (Offheap.unsafe_of_value (Maybe.some t.merge_acc))) + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (Offheap.unsafe_of_value k2); + ReactiveMap.remove t.target (Stable.unsafe_of_value k2); ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k2) - Maybe.none_offheap) + (Stable.unsafe_of_value k2) + Maybe.none_stable) (* Single-pass process + count for scratch *) let process_scratch_entry (t : (_, _, _, _) t) k1 mv = - let k1 = Offheap.unsafe_to_value k1 in - let mv = Offheap.unsafe_to_value mv in + let k1 = Stable.unsafe_to_value k1 in + let mv = Stable.unsafe_to_value mv in t.result.entries_received <- t.result.entries_received + 1; remove_source t k1; if Maybe.is_some mv then ( @@ -132,7 +132,7 @@ let process_scratch_entry (t : (_, _, _, _) t) k1 mv = else t.result.removes_received <- t.result.removes_received + 1 let count_output_entry (r : process_result) _k mv = - let mv = Offheap.unsafe_to_value mv in + let mv = Stable.unsafe_to_value mv in if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 @@ -164,13 +164,13 @@ let init_entry (t : (_, _, _, _) t) k1 v1 = let iter_target f t = ReactiveMap.iter - (fun k v -> f (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value v)) + (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Offheap.unsafe_of_value k) |> Maybe.to_option + ReactiveMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option |> function - | Some v -> Maybe.some (Offheap.unsafe_to_value v) + | Some v -> Maybe.some (Stable.unsafe_to_value v) | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 5f1c3e77b8a..66920237485 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -19,14 +19,14 @@ val create : ('k1, 'v1, 'k2, 'v2) t val destroy : ('k1, 'v1, 'k2, 'v2) t -> unit -(** Release flatMap-owned off-heap storage. The state must not be used +(** Release flatMap-owned stable storage. The state must not be used afterwards. *) val output_wave : ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) val push : - ('k1, 'v1, 'k2, 'v2) t -> 'k1 Offheap.t -> 'v1 Maybe.t Offheap.t -> unit + ('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 diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 4eec3b786ec..af1c7576e89 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -41,15 +41,15 @@ and process_result = { let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveSet.add t.affected (Offheap.unsafe_of_value k3) + ReactiveSet.add t.affected (Stable.unsafe_of_value k3) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; ReactiveMap.replace t.target - (Offheap.unsafe_of_value k3) - (Offheap.unsafe_of_value v3) + (Stable.unsafe_of_value k3) + (Stable.unsafe_of_value v3) let create ~key_of ~f ~merge ~right_get = let rec t = @@ -104,7 +104,7 @@ let push_right t k v_opt = ReactiveMap.replace t.right_scratch k v_opt let remove_one_contribution_key (t : (_, _, _, _, _, _) t) k3 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 t.current_k1; - ReactiveSet.add t.affected (Offheap.unsafe_of_value k3) + ReactiveSet.add t.affected (Stable.unsafe_of_value k3) let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; @@ -112,11 +112,11 @@ let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = let mb = - ReactiveMap.find_maybe t.left_to_right_key (Offheap.unsafe_of_value k1) + ReactiveMap.find_maybe t.left_to_right_key (Stable.unsafe_of_value k1) in if Maybe.is_some mb then ( - let old_k2 = Offheap.unsafe_to_value (Maybe.unsafe_get mb) in - ReactiveMap.remove t.left_to_right_key (Offheap.unsafe_of_value k1); + let old_k2 = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + ReactiveMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys old_k2 k1) @@ -125,15 +125,15 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = unlink_right_key t k1; let k2 = t.key_of k1 v1 in ReactiveMap.replace t.left_to_right_key - (Offheap.unsafe_of_value k1) - (Offheap.unsafe_of_value k2); + (Stable.unsafe_of_value k1) + (Stable.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; t.f k1 v1 right_val t.emit_fn let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = - ReactiveMap.remove t.left_entries (Offheap.unsafe_of_value k1); + ReactiveMap.remove t.left_entries (Stable.unsafe_of_value k1); remove_left_contributions t k1; unlink_right_key t k1 @@ -145,34 +145,34 @@ let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _, _, _) t) k3 = - let k3 = Offheap.unsafe_to_value k3 in + let k3 = Stable.unsafe_to_value k3 in if ReactivePoolMapMap.inner_cardinal t.contributions k3 > 0 then ( t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; ReactiveMap.replace t.target - (Offheap.unsafe_of_value k3) - (Offheap.unsafe_of_value t.merge_acc); + (Stable.unsafe_of_value k3) + (Stable.unsafe_of_value t.merge_acc); ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k3) - (Offheap.unsafe_of_value (Maybe.some t.merge_acc))) + (Stable.unsafe_of_value k3) + (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (Offheap.unsafe_of_value k3); + ReactiveMap.remove t.target (Stable.unsafe_of_value k3); ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k3) - Maybe.none_offheap) + (Stable.unsafe_of_value k3) + Maybe.none_stable) (* Single-pass process + count for left scratch *) let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = - let k1 = Offheap.unsafe_to_value k1 in - let mv = Offheap.unsafe_to_value mv in + let k1 = Stable.unsafe_to_value k1 in + let mv = Stable.unsafe_to_value 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 ReactiveMap.replace t.left_entries - (Offheap.unsafe_of_value k1) - (Offheap.unsafe_of_value v1); + (Stable.unsafe_of_value k1) + (Stable.unsafe_of_value v1); process_left_entry t k1 v1) else ( t.result.removes_received <- t.result.removes_received + 1; @@ -180,14 +180,14 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = - let mb = ReactiveMap.find_maybe t.left_entries (Offheap.unsafe_of_value k1) in + let mb = ReactiveMap.find_maybe t.left_entries (Stable.unsafe_of_value k1) in if Maybe.is_some mb then - process_left_entry t k1 (Offheap.unsafe_to_value (Maybe.unsafe_get mb)) + process_left_entry t k1 (Stable.unsafe_to_value (Maybe.unsafe_get mb)) (* Single-pass process + count for right scratch *) let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = - let k2 = Offheap.unsafe_to_value k2 in - let _mv = Offheap.unsafe_to_value _mv in + let k2 = Stable.unsafe_to_value k2 in + let _mv = Stable.unsafe_to_value _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; @@ -196,7 +196,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = ReactiveHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = - let mv = Offheap.unsafe_to_value mv in + let mv = Stable.unsafe_to_value mv in if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 @@ -227,12 +227,12 @@ let process (t : (_, _, _, _, _, _) t) = let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = ReactiveMap.replace t.left_entries - (Offheap.unsafe_of_value k1) - (Offheap.unsafe_of_value v1); + (Stable.unsafe_of_value k1) + (Stable.unsafe_of_value v1); let k2 = t.key_of k1 v1 in ReactiveMap.replace t.left_to_right_key - (Offheap.unsafe_of_value k1) - (Offheap.unsafe_of_value k2); + (Stable.unsafe_of_value k1) + (Stable.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; let right_val = t.right_get k2 in t.current_k1 <- k1; @@ -240,13 +240,13 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = let iter_target f t = ReactiveMap.iter - (fun k v -> f (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value v)) + (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Offheap.unsafe_of_value k) |> Maybe.to_option + ReactiveMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option |> function - | Some v -> Maybe.some (Offheap.unsafe_to_value v) + | Some v -> Maybe.some (Stable.unsafe_to_value v) | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index 0ebf789bb9c..376d934b5e0 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -21,7 +21,7 @@ val create : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t val destroy : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit -(** Release join-owned off-heap storage. The state must not be used +(** Release join-owned stable storage. The state must not be used afterwards. *) val output_wave : @@ -30,15 +30,15 @@ val output_wave : val push_left : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> - 'k1 Offheap.t -> - 'v1 Maybe.t Offheap.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 Offheap.t -> - 'v2 Maybe.t Offheap.t -> + 'k2 Stable.t -> + 'v2 Maybe.t Stable.t -> unit (** Push an entry into the right scratch table. *) diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/ReactiveMap.ml index 250ece715bc..f2e5e44eb59 100644 --- a/analysis/reactive/src/ReactiveMap.ml +++ b/analysis/reactive/src/ReactiveMap.ml @@ -9,8 +9,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 Offheap.t = Obj.magic empty_sentinel -let[@inline] tomb_slot () : 'a Offheap.t = Obj.magic tomb_sentinel +let[@inline] empty_slot () : 'a Stable.t = Obj.magic empty_sentinel +let[@inline] tomb_slot () : 'a Stable.t = Obj.magic tomb_sentinel let key_capacity t = Allocator.Block2.capacity t.keys let population t = Allocator.Block2.get0 t.keys @@ -19,7 +19,7 @@ let occupation t = Allocator.Block2.get1 t.keys let set_occupation t n = Allocator.Block2.set1 t.keys n let[@inline] mask t = key_capacity t - 1 -let[@inline] start t x = Hashtbl.hash (Offheap.unsafe_to_value x) land mask t +let[@inline] start t x = Hashtbl.hash (Stable.unsafe_to_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 @@ -46,7 +46,7 @@ let clear t = clear_keys t let insert_absent t k v = - let empty : 'k Offheap.t = empty_slot () in + let empty : 'k Stable.t = empty_slot () in let j = ref (start t k) in while Allocator.Block2.get t.keys !j != empty do j := next t !j @@ -84,8 +84,8 @@ let maybe_grow_before_insert t = let replace t k v = maybe_grow_before_insert t; - let empty : 'k Offheap.t = empty_slot () in - let tomb : 'k Offheap.t = tomb_slot () in + 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 @@ -108,8 +108,8 @@ let replace t k v = done let remove t k = - let empty : 'k Offheap.t = empty_slot () in - let tomb : 'k Offheap.t = tomb_slot () in + 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 @@ -124,8 +124,8 @@ let remove t k = done let mem t k = - let empty : 'k Offheap.t = empty_slot () in - let tomb : 'k Offheap.t = tomb_slot () in + 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 @@ -141,8 +141,8 @@ let mem t k = !found let find_maybe t k = - let empty : 'k Offheap.t = empty_slot () in - let tomb : 'k Offheap.t = tomb_slot () in + 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 @@ -158,8 +158,8 @@ let find_maybe t k = !found let iter_with f arg t = - let empty : 'k Offheap.t = empty_slot () in - let tomb : 'k Offheap.t = tomb_slot () in + 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 key_capacity t - 1 do let k = Allocator.Block2.get t.keys i in diff --git a/analysis/reactive/src/ReactiveMap.mli b/analysis/reactive/src/ReactiveMap.mli index 890e86ebe08..10eba293d7b 100644 --- a/analysis/reactive/src/ReactiveMap.mli +++ b/analysis/reactive/src/ReactiveMap.mli @@ -1,4 +1,4 @@ -(** Off-heap mutable maps for reactive internals. *) +(** Stable mutable maps for reactive internals. *) type ('k, 'v) t @@ -6,17 +6,17 @@ val create : unit -> ('k, 'v) t val destroy : ('k, 'v) t -> unit val clear : ('k, 'v) t -> unit -val replace : ('k, 'v) t -> 'k Offheap.t -> 'v Offheap.t -> unit +val replace : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t -> unit -val remove : ('k, 'v) t -> 'k Offheap.t -> unit +val remove : ('k, 'v) t -> 'k Stable.t -> unit -val mem : ('k, 'v) t -> 'k Offheap.t -> bool +val mem : ('k, 'v) t -> 'k Stable.t -> bool -val find_maybe : ('k, 'v) t -> 'k Offheap.t -> 'v Offheap.t Maybe.t +val find_maybe : ('k, 'v) t -> 'k Stable.t -> 'v Stable.t Maybe.t val iter_with : - ('a -> 'k Offheap.t -> 'v Offheap.t -> unit) -> 'a -> ('k, 'v) t -> unit + ('a -> 'k Stable.t -> 'v Stable.t -> unit) -> 'a -> ('k, 'v) t -> unit -val iter : ('k Offheap.t -> 'v Offheap.t -> unit) -> ('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/ReactiveSet.ml b/analysis/reactive/src/ReactiveSet.ml index 9e94a10a403..36afcb4e4a8 100644 --- a/analysis/reactive/src/ReactiveSet.ml +++ b/analysis/reactive/src/ReactiveSet.ml @@ -3,9 +3,9 @@ - ['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 Offheap.t]. + - Data slots: keys, stored as ['a Stable.t]. - The backing block lives off-heap. Elements are ordinary OCaml values whose + The backing block lives stable. Elements are ordinary OCaml values whose storage invariant has already been established before insertion. Data slots contain either: @@ -20,8 +20,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 Offheap.t) -let[@inline] tomb_sentinel = fun () -> (Obj.magic tomb : 'a Offheap.t) +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 @@ -29,7 +29,7 @@ let set_population = Allocator.Block2.set0 let mask = Allocator.Block2.get1 let set_mask = Allocator.Block2.set1 -let[@inline] start t x = Hashtbl.hash (Offheap.unsafe_to_value x) land mask t +let[@inline] start t x = Hashtbl.hash (Stable.unsafe_to_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 @@ -53,7 +53,7 @@ let clear t = set_population t 0; clear_slots t -let add_absent_key (type a) (t : a t) (x : a Offheap.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 @@ -83,7 +83,7 @@ let maybe_grow_before_add (type a) (t : a t) = 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 Offheap.t) = +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 @@ -102,7 +102,7 @@ let add (type a) (t : a t) (x : a Offheap.t) = else j := next t !j done -let remove (type a) (t : a t) (x : a Offheap.t) = +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 @@ -116,7 +116,7 @@ let remove (type a) (t : a t) (x : a Offheap.t) = else j := next t !j done -let mem (type a) (t : a t) (x : a Offheap.t) = +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 @@ -131,7 +131,7 @@ let mem (type a) (t : a t) (x : a Offheap.t) = done; !found -let iter_with (type a k) (f : a -> k Offheap.t -> unit) (arg : a) (t : k t) = +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 diff --git a/analysis/reactive/src/ReactiveSet.mli b/analysis/reactive/src/ReactiveSet.mli index aba3b9405f2..ee2726df09e 100644 --- a/analysis/reactive/src/ReactiveSet.mli +++ b/analysis/reactive/src/ReactiveSet.mli @@ -1,4 +1,4 @@ -(** Off-heap mutable sets for reactive internals. +(** Stable mutable sets for reactive internals. Elements are ordinary OCaml values. The set's backing storage lives in the custom allocator via {!Allocator.Block2}. *) @@ -9,22 +9,22 @@ val create : unit -> 'a t (** Create an empty set. *) val destroy : 'a t -> unit -(** Release the set's owned off-heap storage. The set must not be used +(** 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 Offheap.t -> unit +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 Offheap.t -> unit +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 Offheap.t -> bool +val mem : 'a t -> 'a Stable.t -> bool (** Test whether the set contains an element. *) -val iter_with : ('b -> 'a Offheap.t -> unit) -> 'b -> 'a t -> unit +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 cardinal : 'a t -> int diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml index af40716a095..e6047cb8023 100644 --- a/analysis/reactive/src/ReactiveTable.ml +++ b/analysis/reactive/src/ReactiveTable.ml @@ -10,13 +10,13 @@ let capacity (t : 'a t) = Allocator.Block.capacity t - data_offset let create ~initial_capacity : 'a t = if initial_capacity < 0 then invalid_arg "ReactiveTable.create"; let t = Allocator.Block.create ~capacity:(initial_capacity + data_offset) in - Allocator.Block.set t length_slot (Obj.magic (Offheap.int 0)); + Allocator.Block.set t length_slot (Obj.magic (Stable.int 0)); t let destroy = Allocator.Block.destroy let clear (t : 'a t) = - Allocator.Block.set t length_slot (Obj.magic (Offheap.int 0)) + Allocator.Block.set t length_slot (Obj.magic (Stable.int 0)) let ensure_capacity (t : 'a t) needed = let old_capacity = capacity t in @@ -42,13 +42,13 @@ let push (t : 'a t) value = let next_len = len + 1 in ensure_capacity t next_len; Allocator.Block.set t (len + data_offset) (Obj.magic value); - Allocator.Block.set t length_slot (Obj.magic (Offheap.int next_len)) + Allocator.Block.set t length_slot (Obj.magic (Stable.int next_len)) let pop (t : 'a t) = let len = length t in if len = 0 then invalid_arg "ReactiveTable.pop"; let last = Obj.magic (Allocator.Block.get t (len - 1 + data_offset)) in - Allocator.Block.set t length_slot (Obj.magic (Offheap.int (len - 1))); + Allocator.Block.set t length_slot (Obj.magic (Stable.int (len - 1))); last let shrink_to_fit (t : 'a t) = diff --git a/analysis/reactive/src/ReactiveTable.mli b/analysis/reactive/src/ReactiveTable.mli index 8cf2242cf8f..8dfed053eba 100644 --- a/analysis/reactive/src/ReactiveTable.mli +++ b/analysis/reactive/src/ReactiveTable.mli @@ -1,7 +1,7 @@ type 'a t val create : initial_capacity:int -> 'a t -(** Create an extensible off-heap table. +(** Create an extensible stable table. Stored values are raw OCaml values kept outside the GC's scanned heap. This is only safe for immediates, or for heap values that are: @@ -10,14 +10,14 @@ val create : initial_capacity:int -> 'a t Intended reactive protocol: 1. Produce a wave of fresh OCaml values on the heap. - 2. Promote them out of the minor heap before off-heap publication. - 3. Insert them into off-heap reactive tables during the allocation-free + 2. Promote them out of the minor heap before stable publication. + 3. Insert them into stable reactive tables during the allocation-free processing phase. 4. After the iteration finishes, flush/remove table entries as needed. 5. Only then drop the ordinary OCaml roots for removed values. Violating this protocol is unsafe: - - minor-heap values may move, leaving stale pointers off-heap + - minor-heap values may move, leaving stale pointers stable - unrooted major-heap values may be reclaimed *) val destroy : 'a t -> unit @@ -32,13 +32,13 @@ val capacity : 'a t -> int val clear : 'a t -> unit (** Remove all elements from the table without releasing its storage. *) -val get : 'a t -> int -> 'a Offheap.t -val set : 'a t -> int -> 'a Offheap.t -> unit +val get : 'a t -> int -> 'a Stable.t +val set : 'a t -> int -> 'a Stable.t -> unit -val push : 'a t -> 'a Offheap.t -> unit +val push : 'a t -> 'a Stable.t -> unit (** Append an element, growing via the allocator when needed. *) -val pop : 'a t -> 'a Offheap.t +val pop : 'a t -> 'a Stable.t (** Remove and return the last element. *) val shrink_to_fit : 'a t -> unit diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index f3f66f1b3ec..3f988af7993 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -60,76 +60,66 @@ let push_right t k mv = ReactiveMap.replace t.right_scratch k mv (* Module-level helpers for iter_with — avoid closure allocation *) let apply_left_entry t k mv = - let k = Offheap.unsafe_to_value k in - let mv = Offheap.unsafe_to_value mv in + let k = Stable.unsafe_to_value k in + let mv = Stable.unsafe_to_value mv in let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( - ReactiveMap.replace t.left_values - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.unsafe_get mv)); + ReactiveMap.replace t.left_values (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.left_values (Offheap.unsafe_of_value k); + ReactiveMap.remove t.left_values (Stable.unsafe_of_value k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (Offheap.unsafe_of_value k) + ReactiveSet.add t.affected (Stable.unsafe_of_value k) let apply_right_entry t k mv = - let k = Offheap.unsafe_to_value k in - let mv = Offheap.unsafe_to_value mv in + let k = Stable.unsafe_to_value k in + let mv = Stable.unsafe_to_value mv in let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( - ReactiveMap.replace t.right_values - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.unsafe_get mv)); + ReactiveMap.replace t.right_values (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.right_values (Offheap.unsafe_of_value k); + ReactiveMap.remove t.right_values (Stable.unsafe_of_value k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (Offheap.unsafe_of_value k) + ReactiveSet.add t.affected (Stable.unsafe_of_value k) let recompute_affected_entry t k = - let k = Offheap.unsafe_to_value k in + let k = Stable.unsafe_to_value k in let r = t.result in - let lv = ReactiveMap.find_maybe t.left_values (Offheap.unsafe_of_value k) in - let rv = ReactiveMap.find_maybe t.right_values (Offheap.unsafe_of_value k) in + let lv = ReactiveMap.find_maybe t.left_values (Stable.unsafe_of_value k) in + let rv = ReactiveMap.find_maybe t.right_values (Stable.unsafe_of_value 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 - (Offheap.unsafe_to_value (Maybe.unsafe_get lv)) - (Offheap.unsafe_to_value (Maybe.unsafe_get rv)) + (Stable.unsafe_to_value (Maybe.unsafe_get lv)) + (Stable.unsafe_to_value (Maybe.unsafe_get rv)) in - ReactiveMap.replace t.target - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value merged); - ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.some merged))) + ReactiveMap.replace t.target (Stable.unsafe_of_value k) + (Stable.unsafe_of_value merged); + ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some merged))) else - let v = Offheap.unsafe_to_value (Maybe.unsafe_get lv) in - ReactiveMap.replace t.target - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value v); - ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.some v))) + let v = Stable.unsafe_to_value (Maybe.unsafe_get lv) in + ReactiveMap.replace t.target (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v); + ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v))) else if has_right then ( - let v = Offheap.unsafe_to_value (Maybe.unsafe_get rv) in - ReactiveMap.replace t.target - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value v); - ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.some v))) + let v = Stable.unsafe_to_value (Maybe.unsafe_get rv) in + ReactiveMap.replace t.target (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v); + ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v))) else ( - ReactiveMap.remove t.target (Offheap.unsafe_of_value k); - ReactiveWave.push t.output_wave - (Offheap.unsafe_of_value k) - Maybe.none_offheap); + ReactiveMap.remove t.target (Stable.unsafe_of_value k); + ReactiveWave.push t.output_wave (Stable.unsafe_of_value 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 @@ -157,36 +147,32 @@ let process t = r let init_left t k v = - ReactiveMap.replace t.left_values - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value v); - ReactiveMap.replace t.target - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value v) + ReactiveMap.replace t.left_values (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v); + ReactiveMap.replace t.target (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v) let init_right t k v = - ReactiveMap.replace t.right_values - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value v); - let lv = ReactiveMap.find_maybe t.left_values (Offheap.unsafe_of_value k) in + ReactiveMap.replace t.right_values (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v); + let lv = ReactiveMap.find_maybe t.left_values (Stable.unsafe_of_value k) in let merged = if Maybe.is_some lv then - t.merge (Offheap.unsafe_to_value (Maybe.unsafe_get lv)) v + t.merge (Stable.unsafe_to_value (Maybe.unsafe_get lv)) v else v in - ReactiveMap.replace t.target - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value merged) + ReactiveMap.replace t.target (Stable.unsafe_of_value k) + (Stable.unsafe_of_value merged) let iter_target f t = ReactiveMap.iter - (fun k v -> f (Offheap.unsafe_to_value k) (Offheap.unsafe_to_value v)) + (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Offheap.unsafe_of_value k) |> Maybe.to_option + ReactiveMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option |> function - | Some v -> Maybe.some (Offheap.unsafe_to_value v) + | Some v -> Maybe.some (Stable.unsafe_to_value v) | None -> Maybe.none let target_length t = ReactiveMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index f9c5db642e0..e0f18a8a7fd 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -17,16 +17,16 @@ val create : merge:('v -> 'v -> 'v) -> ('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 off-heap storage. The state must not be used +(** Release union-owned stable storage. The state must not be used afterwards. *) val output_wave : ('k, 'v) t -> ('k, 'v Maybe.t) ReactiveWave.t (** The owned output wave populated by [process]. *) -val push_left : ('k, 'v) t -> 'k Offheap.t -> 'v Maybe.t Offheap.t -> unit +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 Offheap.t -> 'v Maybe.t Offheap.t -> unit +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 diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/ReactiveWave.ml index f357eae5295..40042d35850 100644 --- a/analysis/reactive/src/ReactiveWave.ml +++ b/analysis/reactive/src/ReactiveWave.ml @@ -28,7 +28,7 @@ let ensure_capacity (t : ('k, 'v) t) needed = done; Allocator.Block2.resize t ~capacity:(!next * entry_width)) -let push (type k v) (t : (k, v) t) (k : k Offheap.t) (v : v Offheap.t) = +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 @@ -36,7 +36,7 @@ let push (type k v) (t : (k, v) t) (k : k Offheap.t) (v : v Offheap.t) = 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 Offheap.t -> v Offheap.t -> unit) = +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 @@ -46,7 +46,7 @@ let iter (type k v) (t : (k, v) t) (f : k Offheap.t -> v Offheap.t -> unit) = done let iter_with (type a k v) (t : (k, v) t) - (f : a -> k Offheap.t -> v Offheap.t -> unit) (arg : a) = + (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 diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/ReactiveWave.mli index 01ecbd279b2..3eaa6cb973f 100644 --- a/analysis/reactive/src/ReactiveWave.mli +++ b/analysis/reactive/src/ReactiveWave.mli @@ -1,6 +1,6 @@ -(** A wave is a growable batch of key/value entries stored in off-heap +(** A wave is a growable batch of key/value entries stored in stable allocator-backed storage. Its API is marked with - [Offheap.t] so call sites make the boundary explicit. + [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. *) @@ -14,16 +14,16 @@ 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 off-heap storage. The wave must not be used after this. *) +(** Release the wave's stable storage. The wave must not be used after this. *) -val push : ('k, 'v) t -> 'k Offheap.t -> 'v Offheap.t -> unit -(** Append one off-heap-marked entry to the wave. Callers are currently - responsible for establishing the off-heap invariant before calling. *) +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 Offheap.t -> 'v Offheap.t -> unit) -> unit +val iter : ('k, 'v) t -> ('k Stable.t -> 'v Stable.t -> unit) -> unit val iter_with : - ('k, 'v) t -> ('a -> 'k Offheap.t -> 'v Offheap.t -> unit) -> 'a -> unit + ('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. *) diff --git a/analysis/reactive/src/Offheap.ml b/analysis/reactive/src/Stable.ml similarity index 80% rename from analysis/reactive/src/Offheap.ml rename to analysis/reactive/src/Stable.ml index 18500ddf5ef..5f2dcd1b146 100644 --- a/analysis/reactive/src/Offheap.ml +++ b/analysis/reactive/src/Stable.ml @@ -9,5 +9,5 @@ let int x = unsafe_of_value x let unit x = unsafe_of_value x let of_value x = - if is_in_minor_heap x then invalid_arg "Offheap.of_value"; + 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 00000000000..a7e0927c7ce --- /dev/null +++ b/analysis/reactive/src/Stable.mli @@ -0,0 +1,25 @@ +(** Values marked for storage in stable containers. + + This type does not prove safety. It marks values that are crossing the + stable boundary so call sites can be audited explicitly. *) + +type 'a t + +val unsafe_of_value : 'a -> 'a t +(** Unsafely mark a value as suitable for stable storage. The caller must + ensure the stable invariants hold. *) + +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 -> unit t +(** Safely mark [()] as suitable for stable storage. *) + +val unsafe_to_value : 'a t -> 'a +(** Unsafely recover a regular OCaml value from a stable-marked value. *) diff --git a/analysis/reactive/src/OffheapList.ml b/analysis/reactive/src/StableList.ml similarity index 76% rename from analysis/reactive/src/OffheapList.ml rename to analysis/reactive/src/StableList.ml index b4a2a8cf1d1..d22801743a5 100644 --- a/analysis/reactive/src/OffheapList.ml +++ b/analysis/reactive/src/StableList.ml @@ -1,12 +1,12 @@ type 'a inner = 'a list -type 'a t = 'a inner Offheap.t +type 'a t = 'a inner Stable.t -let unsafe_of_list = Offheap.unsafe_of_value -let of_list = Offheap.of_value -let list_of = Offheap.unsafe_to_value -let unsafe_of_offheap_list xs = unsafe_of_list (Offheap.unsafe_to_value xs) +let unsafe_of_list = Stable.unsafe_of_value +let of_list = Stable.of_value +let list_of = Stable.unsafe_to_value +let of_stable_list xs = xs -let empty () : 'a t = unsafe_of_list [] +let empty () : 'a t = Stable.of_value [] let is_empty xs = match list_of xs with diff --git a/analysis/reactive/src/OffheapList.mli b/analysis/reactive/src/StableList.mli similarity index 61% rename from analysis/reactive/src/OffheapList.mli rename to analysis/reactive/src/StableList.mli index 701a28424f6..02abd11a87e 100644 --- a/analysis/reactive/src/OffheapList.mli +++ b/analysis/reactive/src/StableList.mli @@ -1,20 +1,20 @@ -(** Off-heap-marked OCaml lists. +(** Stable-marked OCaml lists. The list cells are ordinary OCaml heap values. This type makes the - boundary explicit when such a list is stored in an off-heap container. *) + boundary explicit when such a list is stored in a stable container. *) type 'a inner -type 'a t = 'a inner Offheap.t +type 'a t = 'a inner Stable.t val unsafe_of_list : 'a list -> 'a t -(** Reinterpret a list as offheap-marked without checking. *) +(** Reinterpret a list as stable-marked 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 unsafe_of_offheap_list : 'a list Offheap.t -> 'a t -(** Reinterpret an already offheap-marked list as an offheap-list value. *) +val of_stable_list : 'a list Stable.t -> 'a t +(** Reinterpret an already stable-marked list as a stable-list value. *) val empty : unit -> 'a t val is_empty : 'a t -> bool diff --git a/analysis/reactive/src/ReactiveFifo.ml b/analysis/reactive/src/StableQueue.ml similarity index 93% rename from analysis/reactive/src/ReactiveFifo.ml rename to analysis/reactive/src/StableQueue.ml index 1d6f3484e74..461b53fe528 100644 --- a/analysis/reactive/src/ReactiveFifo.ml +++ b/analysis/reactive/src/StableQueue.ml @@ -3,7 +3,7 @@ - ['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 Offheap.t]. + - 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 @@ -52,7 +52,7 @@ let push t x = set_tail t (tail_i + 1) let pop t = - if is_empty t then invalid_arg "ReactiveFifo.pop: empty"; + 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); diff --git a/analysis/reactive/src/ReactiveFifo.mli b/analysis/reactive/src/StableQueue.mli similarity index 68% rename from analysis/reactive/src/ReactiveFifo.mli rename to analysis/reactive/src/StableQueue.mli index 0f5880e093f..ca1037dc581 100644 --- a/analysis/reactive/src/ReactiveFifo.mli +++ b/analysis/reactive/src/StableQueue.mli @@ -1,4 +1,4 @@ -(** Off-heap FIFO queues for reactive internals. *) +(** Stable FIFO queues for reactive internals. *) type 'a t @@ -6,19 +6,19 @@ val create : unit -> 'a t (** Create an empty FIFO queue. *) val destroy : 'a t -> unit -(** Release the queue's owned off-heap storage. The queue must not be used +(** 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 Offheap.t -> unit +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 Offheap.t +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/dune b/analysis/reactive/src/dune index 49ee4fb33cd..d2681147219 100644 --- a/analysis/reactive/src/dune +++ b/analysis/reactive/src/dune @@ -1,7 +1,7 @@ (library (name reactive) (wrapped false) - (private_modules ReactiveFifo) + (private_modules StableQueue) (foreign_stubs (language c) (names reactive_allocator_stubs)) diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index a9fbbf4caa7..8f164092d30 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -19,8 +19,8 @@ let track_deltas c = c.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> - let k = Offheap.unsafe_to_value k in - let mv = Offheap.unsafe_to_value mv in + let k = Stable.unsafe_to_value k in + let mv = Stable.unsafe_to_value mv in rev_entries := (k, mv) :: !rev_entries); received := List.rev !rev_entries :: !received); received diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 88dd557a333..e507b50c521 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -16,27 +16,25 @@ let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave let emit_set emit k v = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.some v)); + ReactiveWave.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 offheap-list type. *) + explicit stable-list type. *) let emit_edge_set emit k vs = let w = wave () in ReactiveWave.clear w; - ReactiveWave.push w - (Offheap.unsafe_of_value k) - (Maybe.maybe_offheap_list_to_offheap - (Maybe.some (OffheapList.unsafe_of_list vs))); + ReactiveWave.push w (Stable.unsafe_of_value k) + (Maybe.maybe_stable_list_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 ReactiveWave.clear w; - ReactiveWave.push w (Offheap.unsafe_of_value k) Maybe.none_offheap; + ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable; emit w (** Emit a batch of (key, value) set entries *) @@ -45,9 +43,8 @@ let emit_sets emit entries = ReactiveWave.clear w; List.iter (fun (k, v) -> - ReactiveWave.push w - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.some v))) + ReactiveWave.push w (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v))) entries; emit w @@ -59,15 +56,13 @@ let emit_batch emit entries = (fun (k, v_opt) -> match v_opt with | Some v -> - ReactiveWave.push w - (Offheap.unsafe_of_value k) - (Offheap.unsafe_of_value (Maybe.some v)) - | None -> - ReactiveWave.push w (Offheap.unsafe_of_value k) Maybe.none_offheap) + ReactiveWave.push w (Stable.unsafe_of_value k) + (Stable.unsafe_of_value (Maybe.some v)) + | None -> ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) entries; emit w -(** Emit a batch of edge entries using the explicit offheap-list type. *) +(** Emit a batch of edge entries using the explicit stable-list type. *) let emit_edge_batch emit entries = let w = wave () in ReactiveWave.clear w; @@ -75,12 +70,10 @@ let emit_edge_batch emit entries = (fun (k, vs_opt) -> match vs_opt with | Some vs -> - ReactiveWave.push w - (Offheap.unsafe_of_value k) - (Maybe.maybe_offheap_list_to_offheap - (Maybe.some (OffheapList.unsafe_of_list vs))) - | None -> - ReactiveWave.push w (Offheap.unsafe_of_value k) Maybe.none_offheap) + ReactiveWave.push w (Stable.unsafe_of_value k) + (Maybe.maybe_stable_list_to_stable + (Maybe.some (StableList.unsafe_of_list vs))) + | None -> ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) entries; emit w @@ -91,8 +84,8 @@ let subscribe handler t = t.subscribe (fun wave -> let rev_entries = ref [] in ReactiveWave.iter wave (fun k mv -> - let k = Offheap.unsafe_to_value k in - let mv = Offheap.unsafe_to_value mv in + let k = Stable.unsafe_to_value k in + let mv = Stable.unsafe_to_value mv in rev_entries := (k, mv) :: !rev_entries); handler (List.rev !rev_entries)) From 7fcca4f39781177252400992876d0a0ef7b45e76 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 08:32:53 +0100 Subject: [PATCH 28/54] analysis/reactive: rename ReactiveHash to StableHash and push unsafe_of_list out of fixpoint Rename ReactiveHash module to StableHash since it is a plain hash table with no reactive behavior. Also change edge_wave type to carry StableList.inner instead of raw lists, pushing the unsafe list-to-stable conversion to the boundary where data enters from external waves. Co-Authored-By: Claude Opus 4.6 --- .../reactive/src/CONVERTING_COMBINATORS.md | 42 ++++++------ analysis/reactive/src/POOL_MAP_MAP.md | 2 +- analysis/reactive/src/Reactive.ml | 67 +++++++++++-------- analysis/reactive/src/ReactiveFixpoint.ml | 6 +- analysis/reactive/src/ReactiveFixpoint.mli | 2 +- analysis/reactive/src/ReactiveJoin.ml | 2 +- analysis/reactive/src/ReactivePoolMapMap.ml | 46 ++++++------- analysis/reactive/src/ReactivePoolMapMap.mli | 2 +- analysis/reactive/src/ReactivePoolMapSet.ml | 46 ++++++------- analysis/reactive/src/ReactivePoolMapSet.mli | 4 +- .../src/{ReactiveHash.ml => StableHash.ml} | 0 .../src/{ReactiveHash.mli => StableHash.mli} | 0 analysis/reactive/src/StableList.ml | 1 + analysis/reactive/src/StableList.mli | 3 + analysis/reactive/test/AllocTest.ml | 8 +-- 15 files changed, 122 insertions(+), 109 deletions(-) rename analysis/reactive/src/{ReactiveHash.ml => StableHash.ml} (100%) rename analysis/reactive/src/{ReactiveHash.mli => StableHash.mli} (100%) diff --git a/analysis/reactive/src/CONVERTING_COMBINATORS.md b/analysis/reactive/src/CONVERTING_COMBINATORS.md index dc132bbe225..b34086ea2d4 100644 --- a/analysis/reactive/src/CONVERTING_COMBINATORS.md +++ b/analysis/reactive/src/CONVERTING_COMBINATORS.md @@ -1,7 +1,7 @@ # 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` +`Reactive.ml` into its own private module backed by `StableHash` (Hachis open-addressing tables), following the pattern established by `ReactiveUnion` and `ReactiveFlatMap`. @@ -83,33 +83,33 @@ 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 +StableHash.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 +StableHash.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 +`StableHash.Map`, `StableHash.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 +`StableHash.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 +let r = StableHash.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 +match StableHash.Map.find_opt t.pred_map k with | Some v -> use v | None -> ... ``` @@ -122,19 +122,19 @@ When checking whether any key in map A exists in map B (e.g. ```ocaml (* Zero allocation, early-exit: *) -ReactiveHash.Map.has_common_key pred_set current +StableHash.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; + StableHash.Map.iter (fun k () -> + if StableHash.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 +`StableHash` 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: @@ -192,7 +192,7 @@ for the pattern. 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 +`StableHash` 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. @@ -210,17 +210,17 @@ Add the module to `private_modules` in ### 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` +Use `StableHash.Map` for key-value maps and `StableHash.Set` for dedup sets. ```ocaml type ('k, 'v) t = { (* persistent state *) - target: ('k, 'v) ReactiveHash.Map.t; + target: ('k, 'v) StableHash.Map.t; ... (* scratch — allocated once, cleared per process() *) - scratch: ('k, 'v option) ReactiveHash.Map.t; - affected: 'k ReactiveHash.Set.t; + scratch: ('k, 'v option) StableHash.Map.t; + affected: 'k StableHash.Set.t; (* pre-allocated output buffer *) output_wave: ('k, 'v option) ReactiveWave.t; } @@ -289,13 +289,13 @@ let my_combinator ~name ... = ### 5. Key patterns to follow **Replace per-process-call allocations:** -| Old (Hashtbl) | New (ReactiveHash) | +| Old (Hashtbl) | New (StableHash) | |--------------------------------------------|------------------------------------------| | `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 | +| `Hashtbl.create n` for `seen` | persistent `StableHash.Set`, `clear` | +| `List.filter_map ... recompute_target` | `StableHash.Set.iter` + write to wave | | `count_adds_removes entries` (list walk) | count inline with `ref` during iteration | **Eliminate intermediate lists:** @@ -332,7 +332,7 @@ make -C analysis/reactive test ### Remaining allocations in `ReactiveFixpoint` -Converted to `ReactiveHash`: +Converted to `StableHash`: - 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` @@ -351,6 +351,6 @@ Eliminated intermediate lists, records, and closures: 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). +- **`pred_map` inner maps**: new `StableHash.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/POOL_MAP_MAP.md b/analysis/reactive/src/POOL_MAP_MAP.md index ac75e289c7e..edcbf243250 100644 --- a/analysis/reactive/src/POOL_MAP_MAP.md +++ b/analysis/reactive/src/POOL_MAP_MAP.md @@ -92,7 +92,7 @@ val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko -> int val outer_cardinal : ('ko, 'ki, 'v) t -> int val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) StableHash.Map.t Maybe.t (** Optional: keep internal/private if we want stricter discipline. *) val tighten : ('ko, 'ki, 'v) t -> unit diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 09e7ba3744f..88c03fb0ebe 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -478,8 +478,8 @@ let unsafe_wave_push wave k v = module Source = struct type ('k, 'v) tables = { - tbl: ('k, 'v) ReactiveHash.Map.t; - pending: ('k, 'v Maybe.t) ReactiveHash.Map.t; + tbl: ('k, 'v) StableHash.Map.t; + pending: ('k, 'v Maybe.t) StableHash.Map.t; } let apply_emit (tables : ('k, 'v) tables) k mv = @@ -487,35 +487,35 @@ module Source = struct let mv = Stable.unsafe_to_value mv in if Maybe.is_some mv then ( let v = Maybe.unsafe_get mv in - ReactiveHash.Map.replace tables.tbl k v; - ReactiveHash.Map.replace tables.pending k (Maybe.some v)) + StableHash.Map.replace tables.tbl k v; + StableHash.Map.replace tables.pending k (Maybe.some v)) else ( - ReactiveHash.Map.remove tables.tbl k; - ReactiveHash.Map.replace tables.pending k Maybe.none) + StableHash.Map.remove tables.tbl k; + StableHash.Map.replace tables.pending k Maybe.none) let create ~name () = - let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.create () in + let tbl : ('k, 'v) StableHash.Map.t = StableHash.Map.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 ReactiveHash.Map for zero-alloc deduplication (last-write-wins). *) - let pending : ('k, 'v Maybe.t) ReactiveHash.Map.t = - ReactiveHash.Map.create () + Uses StableHash.Map for zero-alloc deduplication (last-write-wins). *) + let pending : ('k, 'v Maybe.t) StableHash.Map.t = + StableHash.Map.create () in let tables = {tbl; pending} in let pending_count = ref 0 in let process () = - let count = ReactiveHash.Map.cardinal pending in + let count = StableHash.Map.cardinal pending in if count > 0 then ( my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; my_stats.entries_emitted <- my_stats.entries_emitted + count; ReactiveWave.clear output_wave; - ReactiveHash.Map.iter_with unsafe_wave_push output_wave pending; - ReactiveHash.Map.clear pending; + StableHash.Map.iter_with unsafe_wave_push output_wave pending; + StableHash.Map.clear pending; notify_subscribers output_wave !subscribers) - else ReactiveHash.Map.clear pending + else StableHash.Map.clear pending in let destroy () = ReactiveWave.destroy output_wave in @@ -527,9 +527,9 @@ module Source = struct { name; subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> ReactiveHash.Map.iter f tbl); - get = (fun k -> ReactiveHash.Map.find_maybe tbl k); - length = (fun () -> ReactiveHash.Map.cardinal tbl); + iter = (fun f -> StableHash.Map.iter f tbl); + get = (fun k -> StableHash.Map.find_maybe tbl k); + length = (fun () -> StableHash.Map.cardinal tbl); destroy; stats = my_stats; level = 0; @@ -798,9 +798,18 @@ end module Fixpoint = struct let unsafe_wave_map_replace pending k v = - ReactiveHash.Map.replace pending (Stable.unsafe_to_value k) + StableHash.Map.replace pending (Stable.unsafe_to_value k) (Stable.unsafe_to_value v) + let unsafe_edge_wave_map_replace pending k v = + let v : _ Maybe.t = Stable.unsafe_to_value v in + let v = + if Maybe.is_some v then + Maybe.some (StableList.unsafe_inner_of_list (Maybe.unsafe_get v)) + else Maybe.none + in + StableHash.Map.replace pending (Stable.unsafe_to_value k) v + let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = let my_level = max init.level edges.level + 1 in @@ -829,11 +838,11 @@ module Fixpoint = struct let edge_wave = ReactiveWave.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) ReactiveHash.Map.t = - ReactiveHash.Map.create () + let root_pending : ('k, unit Maybe.t) StableHash.Map.t = + StableHash.Map.create () in - let edge_pending : ('k, 'k list Maybe.t) ReactiveHash.Map.t = - ReactiveHash.Map.create () + let edge_pending : ('k, 'k StableList.inner Maybe.t) StableHash.Map.t = + StableHash.Map.create () in let init_pending_count = ref 0 in let edges_pending_count = ref 0 in @@ -852,16 +861,16 @@ module Fixpoint = struct (* Dump pending maps into waves *) ReactiveWave.clear root_wave; ReactiveWave.clear edge_wave; - let root_entries = ReactiveHash.Map.cardinal root_pending in - let edge_entries = ReactiveHash.Map.cardinal edge_pending in - ReactiveHash.Map.iter_with unsafe_wave_push root_wave root_pending; - ReactiveHash.Map.iter_with + let root_entries = StableHash.Map.cardinal root_pending in + let edge_entries = StableHash.Map.cardinal edge_pending in + StableHash.Map.iter_with unsafe_wave_push root_wave root_pending; + StableHash.Map.iter_with (fun wave k mv -> ReactiveWave.push wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value mv)) edge_wave edge_pending; - ReactiveHash.Map.clear root_pending; - ReactiveHash.Map.clear edge_pending; + StableHash.Map.clear root_pending; + StableHash.Map.clear edge_pending; my_stats.entries_received <- my_stats.entries_received + root_entries + edge_entries; @@ -901,7 +910,7 @@ module Fixpoint = struct edges.subscribe (fun wave -> Registry.inc_inflight_node edges.node; edges_pending_count := !edges_pending_count + 1; - ReactiveWave.iter_with wave unsafe_wave_map_replace edge_pending; + ReactiveWave.iter_with wave unsafe_edge_wave_map_replace edge_pending; Registry.mark_dirty_node my_info); (* Initialize from existing data *) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 852d3e8e71d..34b9a21f817 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -451,7 +451,7 @@ let destroy t = let output_wave t = t.output_wave type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t -type 'k edge_wave = ('k, 'k list Maybe.t) ReactiveWave.t +type 'k edge_wave = ('k, 'k StableList.inner Maybe.t) ReactiveWave.t type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t @@ -476,7 +476,7 @@ let has_live_pred_key t pred = ReactiveSet.mem t.current (stable_key pred) let has_live_predecessor t k = let r = ReactivePoolMapSet.find_maybe t.pred_map k in if Maybe.is_some r then - ReactiveHash.Set.exists_with has_live_pred_key t (Maybe.unsafe_get r) + StableHash.Set.exists_with has_live_pred_key t (Maybe.unsafe_get r) else false let add_pred_for_src (t, src) target = add_pred t ~target ~pred:src @@ -662,7 +662,7 @@ let apply_list t ~roots ~edges = let mv = Stable.unsafe_to_value mv in let mv = if Maybe.is_some mv then - Maybe.some (StableList.unsafe_of_list (Maybe.unsafe_get mv)) + Maybe.some (Stable.unsafe_of_value (Maybe.unsafe_get mv)) else Maybe.none in scan_edge_entry t (Stable.unsafe_to_value src) mv) diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 05e9383335c..3f58d1853e6 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -4,7 +4,7 @@ type 'k t This implementation uses fixed-capacity arrays allocated in [create]. *) type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t -type 'k edge_wave = ('k, 'k list Maybe.t) ReactiveWave.t +type 'k edge_wave = ('k, 'k StableList.inner Maybe.t) ReactiveWave.t type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index af1c7576e89..4a005902f89 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -193,7 +193,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = else t.result.removes_received <- t.result.removes_received + 1; let mb = ReactivePoolMapSet.find_maybe t.right_key_to_left_keys k2 in if Maybe.is_some mb then - ReactiveHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) + StableHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = let mv = Stable.unsafe_to_value mv in diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml index 7e4d5c4f20b..f0e7e257481 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.ml +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -4,8 +4,8 @@ map-of-map structures. *) type ('ko, 'ki, 'v) t = { - outer: ('ko, ('ki, 'v) ReactiveHash.Map.t) ReactiveHash.Map.t; - mutable pool: ('ki, 'v) ReactiveHash.Map.t array; + outer: ('ko, ('ki, 'v) StableHash.Map.t) StableHash.Map.t; + mutable pool: ('ki, 'v) StableHash.Map.t array; mutable pool_len: int; mutable recycle_count: int; mutable miss_count: int; @@ -13,7 +13,7 @@ type ('ko, 'ki, 'v) t = { let create ~capacity:pool_capacity = { - outer = ReactiveHash.Map.create (); + outer = StableHash.Map.create (); pool = Array.make pool_capacity (Obj.magic 0); pool_len = 0; recycle_count = 0; @@ -43,59 +43,59 @@ let pool_pop t = else ( t.miss_count <- t.miss_count + 1; ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_map_miss_create; - ReactiveHash.Map.create ()) + StableHash.Map.create ()) let ensure_inner t ko = - let m = ReactiveHash.Map.find_maybe t.outer ko in + let m = StableHash.Map.find_maybe t.outer ko in if Maybe.is_some m then Maybe.unsafe_get m else let inner = pool_pop t in - ReactiveHash.Map.replace t.outer ko inner; + StableHash.Map.replace t.outer ko inner; inner let replace t ko ki v = let inner = ensure_inner t ko in - ReactiveHash.Map.replace inner ki v + StableHash.Map.replace inner ki v let remove_from_inner_and_recycle_if_empty t ko ki = - let mb = ReactiveHash.Map.find_maybe t.outer ko in + let mb = StableHash.Map.find_maybe t.outer ko in if Maybe.is_some mb then ( let inner = Maybe.unsafe_get mb in - ReactiveHash.Map.remove inner ki; - let after = ReactiveHash.Map.cardinal inner in + StableHash.Map.remove inner ki; + let after = StableHash.Map.cardinal inner in if after = 0 then ( - ReactiveHash.Map.remove t.outer ko; - ReactiveHash.Map.clear inner; + StableHash.Map.remove t.outer ko; + StableHash.Map.clear inner; pool_push t inner; t.recycle_count <- t.recycle_count + 1); ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_map_remove_recycle_if_empty) let drain_outer t ko ctx f = - let mb = ReactiveHash.Map.find_maybe t.outer ko in + let mb = StableHash.Map.find_maybe t.outer ko in if Maybe.is_some mb then ( let inner = Maybe.unsafe_get mb in - ReactiveHash.Map.iter_with f ctx inner; - ReactiveHash.Map.remove t.outer ko; - ReactiveHash.Map.clear inner; + StableHash.Map.iter_with f ctx inner; + StableHash.Map.remove t.outer ko; + StableHash.Map.clear inner; pool_push t inner; t.recycle_count <- t.recycle_count + 1; ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_map_drain_outer) -let find_inner_maybe t ko = ReactiveHash.Map.find_maybe t.outer ko +let find_inner_maybe t ko = StableHash.Map.find_maybe t.outer ko let iter_inner_with t ko ctx f = - let mb = ReactiveHash.Map.find_maybe t.outer ko in + let mb = StableHash.Map.find_maybe t.outer ko in if Maybe.is_some mb then - ReactiveHash.Map.iter_with f ctx (Maybe.unsafe_get mb) + StableHash.Map.iter_with f ctx (Maybe.unsafe_get mb) let inner_cardinal t ko = - let mb = ReactiveHash.Map.find_maybe t.outer ko in - if Maybe.is_some mb then ReactiveHash.Map.cardinal (Maybe.unsafe_get mb) + let mb = StableHash.Map.find_maybe t.outer ko in + if Maybe.is_some mb then StableHash.Map.cardinal (Maybe.unsafe_get mb) else 0 -let outer_cardinal t = ReactiveHash.Map.cardinal t.outer +let outer_cardinal t = StableHash.Map.cardinal t.outer -let tighten t = ReactiveHash.Map.tighten t.outer +let tighten t = StableHash.Map.tighten t.outer let debug_miss_count t = t.miss_count diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/ReactivePoolMapMap.mli index 40394943bd5..fe01d3dd02f 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.mli +++ b/analysis/reactive/src/ReactivePoolMapMap.mli @@ -24,7 +24,7 @@ val drain_outer : No-op if [ko] is absent. *) val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) StableHash.Map.t Maybe.t (** Zero-allocation lookup of inner map by outer key. *) val iter_inner_with : diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml index 4f868828544..cb444697afd 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.ml +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -9,8 +9,8 @@ on every source edit). *) type ('k, 'v) t = { - outer: ('k, 'v ReactiveHash.Set.t) ReactiveHash.Map.t; - mutable pool: 'v ReactiveHash.Set.t array; + outer: ('k, 'v StableHash.Set.t) StableHash.Map.t; + mutable pool: 'v StableHash.Set.t array; mutable pool_len: int; mutable recycle_count: int; mutable miss_count: int; @@ -18,7 +18,7 @@ type ('k, 'v) t = { let create ~capacity:pool_capacity = { - outer = ReactiveHash.Map.create (); + outer = StableHash.Map.create (); pool = Array.make pool_capacity (Obj.magic 0); pool_len = 0; recycle_count = 0; @@ -48,60 +48,60 @@ let pool_pop t = else ( t.miss_count <- t.miss_count + 1; ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_set_miss_create; - ReactiveHash.Set.create ()) + StableHash.Set.create ()) let ensure t k = - let m = ReactiveHash.Map.find_maybe t.outer k in + let m = StableHash.Map.find_maybe t.outer k in if Maybe.is_some m then Maybe.unsafe_get m else let set = pool_pop t in - ReactiveHash.Map.replace t.outer k set; + StableHash.Map.replace t.outer k set; set let add t k v = let set = ensure t k in - ReactiveHash.Set.add set v + StableHash.Set.add set v let drain_key t k ctx f = - let mb = ReactiveHash.Map.find_maybe t.outer k in + let mb = StableHash.Map.find_maybe t.outer k in if Maybe.is_some mb then ( let set = Maybe.unsafe_get mb in - ReactiveHash.Set.iter_with f ctx set; - ReactiveHash.Map.remove t.outer k; - ReactiveHash.Set.clear set; + StableHash.Set.iter_with f ctx set; + StableHash.Map.remove t.outer k; + StableHash.Set.clear set; pool_push t set; t.recycle_count <- t.recycle_count + 1; ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_set_drain_key) let remove_from_set_and_recycle_if_empty t k v = - let mb = ReactiveHash.Map.find_maybe t.outer k in + let mb = StableHash.Map.find_maybe t.outer k in if Maybe.is_some mb then ( let set = Maybe.unsafe_get mb in - ReactiveHash.Set.remove set v; - let after = ReactiveHash.Set.cardinal set in + StableHash.Set.remove set v; + let after = StableHash.Set.cardinal set in if after = 0 then ( - ReactiveHash.Map.remove t.outer k; - ReactiveHash.Set.clear set; + StableHash.Map.remove t.outer k; + StableHash.Set.clear set; pool_push t set; t.recycle_count <- t.recycle_count + 1); ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_set_remove_recycle_if_empty) -let find_maybe t k = ReactiveHash.Map.find_maybe t.outer k +let find_maybe t k = StableHash.Map.find_maybe t.outer k -let iter_with t ctx f = ReactiveHash.Map.iter_with f ctx t.outer +let iter_with t ctx f = StableHash.Map.iter_with f ctx t.outer let recycle_inner_set t _k set = - ReactiveHash.Set.clear set; + StableHash.Set.clear set; pool_push t set; t.recycle_count <- t.recycle_count + 1 let clear t = - ReactiveHash.Map.iter_with recycle_inner_set t t.outer; - ReactiveHash.Map.clear t.outer + StableHash.Map.iter_with recycle_inner_set t t.outer; + StableHash.Map.clear t.outer -let tighten t = ReactiveHash.Map.tighten t.outer +let tighten t = StableHash.Map.tighten t.outer -let cardinal t = ReactiveHash.Map.cardinal t.outer +let cardinal t = StableHash.Map.cardinal t.outer let debug_miss_count t = t.miss_count diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli index 656358a104b..3a1eea9dbcc 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.mli +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -20,11 +20,11 @@ val remove_from_set_and_recycle_if_empty : ('k, 'v) t -> 'k -> 'v -> unit (** [remove_from_set_and_recycle_if_empty t k v] removes [v] from [k]'s set. If the set becomes empty, [k] is recycled. No-op if [k] is absent. *) -val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveHash.Set.t Maybe.t +val find_maybe : ('k, 'v) t -> 'k -> 'v StableHash.Set.t Maybe.t (** Zero-allocation lookup. *) val iter_with : - ('k, 'v) t -> 'a -> ('a -> 'k -> 'v ReactiveHash.Set.t -> unit) -> unit + ('k, 'v) t -> 'a -> ('a -> 'k -> 'v StableHash.Set.t -> unit) -> unit (** [iter_with t ctx f] calls [f ctx k set] for each binding. *) val clear : ('k, 'v) t -> unit diff --git a/analysis/reactive/src/ReactiveHash.ml b/analysis/reactive/src/StableHash.ml similarity index 100% rename from analysis/reactive/src/ReactiveHash.ml rename to analysis/reactive/src/StableHash.ml diff --git a/analysis/reactive/src/ReactiveHash.mli b/analysis/reactive/src/StableHash.mli similarity index 100% rename from analysis/reactive/src/ReactiveHash.mli rename to analysis/reactive/src/StableHash.mli diff --git a/analysis/reactive/src/StableList.ml b/analysis/reactive/src/StableList.ml index d22801743a5..f24ed83de9e 100644 --- a/analysis/reactive/src/StableList.ml +++ b/analysis/reactive/src/StableList.ml @@ -2,6 +2,7 @@ type 'a inner = 'a list type 'a t = 'a inner Stable.t let unsafe_of_list = Stable.unsafe_of_value +let unsafe_inner_of_list (l : 'a list) : 'a inner = l let of_list = Stable.of_value let list_of = Stable.unsafe_to_value let of_stable_list xs = xs diff --git a/analysis/reactive/src/StableList.mli b/analysis/reactive/src/StableList.mli index 02abd11a87e..43d17fda19f 100644 --- a/analysis/reactive/src/StableList.mli +++ b/analysis/reactive/src/StableList.mli @@ -9,6 +9,9 @@ type 'a t = 'a inner Stable.t val unsafe_of_list : 'a list -> 'a t (** Reinterpret a list as stable-marked without checking. *) +val unsafe_inner_of_list : 'a list -> 'a inner +(** Reinterpret a list as a [StableList.inner] 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. *) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 7ed87ccecc9..4a22c9cbbd1 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -209,19 +209,19 @@ let test_union_alloc () = (* ---- Join allocation ---- *) let test_join_alloc_n n = - let right_tbl = ReactiveHash.Map.create () in + let right_tbl = StableHash.Map.create () in let state = ReactiveJoin.create ~key_of:(fun k _v -> k) ~f:(fun k v right_mb emit -> if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) ~merge:(fun _l r -> r) - ~right_get:(ReactiveHash.Map.find_maybe right_tbl) + ~right_get:(StableHash.Map.find_maybe right_tbl) in (* Populate: n entries on the right, n on the left *) for i = 0 to n - 1 do - ReactiveHash.Map.replace right_tbl i (i * 10) + StableHash.Map.replace right_tbl i (i * 10) done; for i = 0 to n - 1 do ReactiveJoin.push_left state (stable_int i) @@ -529,7 +529,7 @@ let count_pool_empty_sets pms = let s = {total = 0; empty = 0} in ReactivePoolMapSet.iter_with pms s (fun st _k set -> st.total <- st.total + 1; - if ReactiveHash.Set.cardinal set = 0 then st.empty <- st.empty + 1); + if StableHash.Set.cardinal set = 0 then st.empty <- st.empty + 1); s let test_pool_map_set_pattern_drain_key_churn () = From 6ba99943ae75901824cf5d0605392e3d6f3a97ab Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 09:04:44 +0100 Subject: [PATCH 29/54] analysis/reactive: rename ReactiveMap/ReactiveSet to StableMap/StableSet and use StableMap for fixpoint pending buffers Rename ReactiveMap and ReactiveSet modules to StableMap and StableSet to better reflect their role as stable-boundary-aware data structures. Change fixpoint pending buffers (root_pending, edge_pending) from StableHash.Map to StableMap, eliminating manual Stable.t wrapping/unwrapping at the wave-to-pending and pending-to-wave boundaries. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Reactive.ml | 40 ++- analysis/reactive/src/ReactiveFixpoint.ml | 262 +++++++++--------- analysis/reactive/src/ReactiveFlatMap.ml | 44 +-- analysis/reactive/src/ReactiveJoin.ml | 84 +++--- analysis/reactive/src/ReactivePoolMapMap.ml | 6 +- analysis/reactive/src/ReactiveUnion.ml | 94 +++---- .../src/{ReactiveMap.ml => StableMap.ml} | 0 .../src/{ReactiveMap.mli => StableMap.mli} | 0 .../src/{ReactiveSet.ml => StableSet.ml} | 0 .../src/{ReactiveSet.mli => StableSet.mli} | 0 10 files changed, 262 insertions(+), 268 deletions(-) rename analysis/reactive/src/{ReactiveMap.ml => StableMap.ml} (100%) rename analysis/reactive/src/{ReactiveMap.mli => StableMap.mli} (100%) rename analysis/reactive/src/{ReactiveSet.ml => StableSet.ml} (100%) rename analysis/reactive/src/{ReactiveSet.mli => StableSet.mli} (100%) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 88c03fb0ebe..77607844087 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -797,18 +797,18 @@ end (** {1 Fixpoint} *) module Fixpoint = struct - let unsafe_wave_map_replace pending k v = - StableHash.Map.replace pending (Stable.unsafe_to_value k) - (Stable.unsafe_to_value v) + let stable_wave_map_replace pending k v = StableMap.replace pending k v - let unsafe_edge_wave_map_replace pending k v = + let stable_edge_wave_map_replace pending k v = let v : _ Maybe.t = Stable.unsafe_to_value v in let v = if Maybe.is_some v then Maybe.some (StableList.unsafe_inner_of_list (Maybe.unsafe_get v)) else Maybe.none in - StableHash.Map.replace pending (Stable.unsafe_to_value k) v + StableMap.replace pending k (Stable.unsafe_of_value v) + + let stable_wave_push wave k v = ReactiveWave.push wave k v let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : ('k, unit) t = @@ -838,11 +838,9 @@ module Fixpoint = struct let edge_wave = ReactiveWave.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) StableHash.Map.t = - StableHash.Map.create () - in - let edge_pending : ('k, 'k StableList.inner Maybe.t) StableHash.Map.t = - StableHash.Map.create () + let root_pending : ('k, unit Maybe.t) StableMap.t = StableMap.create () in + let edge_pending : ('k, 'k StableList.inner Maybe.t) StableMap.t = + StableMap.create () in let init_pending_count = ref 0 in let edges_pending_count = ref 0 in @@ -861,16 +859,12 @@ module Fixpoint = struct (* Dump pending maps into waves *) ReactiveWave.clear root_wave; ReactiveWave.clear edge_wave; - let root_entries = StableHash.Map.cardinal root_pending in - let edge_entries = StableHash.Map.cardinal edge_pending in - StableHash.Map.iter_with unsafe_wave_push root_wave root_pending; - StableHash.Map.iter_with - (fun wave k mv -> - ReactiveWave.push wave (Stable.unsafe_of_value k) - (Stable.unsafe_of_value mv)) - edge_wave edge_pending; - StableHash.Map.clear root_pending; - StableHash.Map.clear edge_pending; + 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; my_stats.entries_received <- my_stats.entries_received + root_entries + edge_entries; @@ -887,6 +881,8 @@ module Fixpoint = struct in let destroy () = + StableMap.destroy root_pending; + StableMap.destroy edge_pending; ReactiveWave.destroy root_wave; ReactiveWave.destroy edge_wave; ReactiveFixpoint.destroy state @@ -904,13 +900,13 @@ module Fixpoint = struct init.subscribe (fun wave -> Registry.inc_inflight_node init.node; init_pending_count := !init_pending_count + 1; - ReactiveWave.iter_with wave unsafe_wave_map_replace root_pending; + ReactiveWave.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; - ReactiveWave.iter_with wave unsafe_edge_wave_map_replace edge_pending; + ReactiveWave.iter_with wave stable_edge_wave_map_replace edge_pending; Registry.mark_dirty_node my_info); (* Initialize from existing data *) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 34b9a21f817..8f189adbccb 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -10,27 +10,27 @@ type 'k metrics_state = { mutable rederive_edges_scanned: int; mutable expansion_queue_pops: int; mutable expansion_edges_scanned: int; - scratch_reachable: 'k ReactiveSet.t; + 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 t = { - current: 'k ReactiveSet.t; - edge_map: ('k, 'k StableList.inner) ReactiveMap.t; + current: 'k StableSet.t; + edge_map: ('k, 'k StableList.inner) StableMap.t; pred_map: ('k, 'k) ReactivePoolMapSet.t; - roots: 'k ReactiveSet.t; + roots: 'k StableSet.t; output_wave: ('k, unit Maybe.t) ReactiveWave.t; (* Scratch tables — allocated once, cleared per apply_list call *) - deleted_nodes: 'k ReactiveSet.t; - rederive_pending: 'k ReactiveSet.t; - expansion_seen: 'k ReactiveSet.t; - old_successors_for_changed: ('k, 'k StableList.inner) ReactiveMap.t; - new_successors_for_changed: ('k, 'k StableList.inner) ReactiveMap.t; + deleted_nodes: 'k StableSet.t; + rederive_pending: 'k StableSet.t; + expansion_seen: 'k StableSet.t; + old_successors_for_changed: ('k, 'k StableList.inner) StableMap.t; + new_successors_for_changed: ('k, 'k StableList.inner) StableMap.t; (* Scratch sets for analyze_edge_change / apply_edge_update *) - scratch_set_a: 'k ReactiveSet.t; - scratch_set_b: 'k ReactiveSet.t; - edge_has_new: 'k ReactiveSet.t; + 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; @@ -57,28 +57,28 @@ let[@inline] enqueue q k = StableQueue.push q (stable_key k) [visited] is cleared before use; zero allocation when [visited] is pre-allocated (e.g. Metrics scratch map). *) let bfs_seed_root visited frontier _t k () = - ReactiveSet.add visited (stable_key k); + StableSet.add visited (stable_key k); enqueue frontier k let bfs_visit_succ visited frontier succ = - if not (ReactiveSet.mem visited (stable_key succ)) then ( - ReactiveSet.add visited (stable_key succ); + if not (StableSet.mem visited (stable_key succ)) then ( + StableSet.add visited (stable_key succ); enqueue frontier succ) let compute_reachable ~visited t = - ReactiveSet.clear visited; + StableSet.clear visited; let frontier = t.delete_queue in StableQueue.clear frontier; let node_work = ref 0 in let edge_work = ref 0 in - ReactiveSet.iter_with + StableSet.iter_with (fun (visited, frontier) k -> bfs_seed_root visited frontier t (Stable.unsafe_to_value k) ()) (visited, frontier) t.roots; while not (StableQueue.is_empty frontier) do let k = StableQueue.pop frontier in incr node_work; - let r = ReactiveMap.find_maybe t.edge_map k in + let r = StableMap.find_maybe t.edge_map k in if Maybe.is_some r then ( let succs = Maybe.unsafe_get r in edge_work := !edge_work + StableList.length succs; @@ -227,9 +227,9 @@ module Invariants = struct (* Debug-only: copies a set into a Hashtbl for diffing. These allocations are acceptable since Invariants is opt-in debug code. *) - let copy_set_to_hashtbl (s : 'k ReactiveSet.t) = - let out = Hashtbl.create (ReactiveSet.cardinal s) in - ReactiveSet.iter_with + let copy_set_to_hashtbl (s : 'k StableSet.t) = + let out = Hashtbl.create (StableSet.cardinal s) in + StableSet.iter_with (fun out k -> Hashtbl.replace out (Stable.unsafe_to_value k) ()) out s; out @@ -259,14 +259,14 @@ module Invariants = struct List.iter (fun src -> let r_old = - ReactiveMap.find_maybe old_successors_for_changed (stable_key src) + StableMap.find_maybe old_successors_for_changed (stable_key src) in let old_succs = if Maybe.is_some r_old then Maybe.unsafe_get r_old else StableList.empty () in let r_new = - ReactiveMap.find_maybe new_successors_for_changed (stable_key src) + StableMap.find_maybe new_successors_for_changed (stable_key src) in let new_succs = if Maybe.is_some r_new then Maybe.unsafe_get r_new @@ -275,7 +275,7 @@ module Invariants = struct let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs in - let actual_has_new = ReactiveSet.mem edge_has_new (stable_key src) in + let actual_has_new = StableSet.mem edge_has_new (stable_key src) in assert_ (expected_has_new = actual_has_new) "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") @@ -284,18 +284,18 @@ module Invariants = struct let assert_deleted_nodes_closed ~current ~deleted_nodes ~(old_successors : 'k -> 'k StableList.t) = if enabled then - ReactiveSet.iter_with + StableSet.iter_with (fun () k -> let k = Stable.unsafe_to_value k in assert_ - (ReactiveSet.mem current (stable_key k)) + (StableSet.mem current (stable_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; StableList.iter (fun succ -> - if ReactiveSet.mem current (stable_key succ) then + if StableSet.mem current (stable_key succ) then assert_ - (ReactiveSet.mem deleted_nodes (stable_key succ)) + (StableSet.mem deleted_nodes (stable_key succ)) "ReactiveFixpoint.apply invariant failed: deleted closure \ broken") (old_successors k)) @@ -303,10 +303,10 @@ module Invariants = struct let assert_no_supported_deleted_left ~deleted_nodes ~current ~supported = if enabled then - ReactiveSet.iter_with + StableSet.iter_with (fun () k -> let k = Stable.unsafe_to_value k in - if not (ReactiveSet.mem current (stable_key k)) then + if not (StableSet.mem current (stable_key k)) then assert_ (not (supported k)) "ReactiveFixpoint.apply invariant failed: supported deleted node \ @@ -316,7 +316,7 @@ module Invariants = struct let assert_current_minus_deleted ~pre_current ~current ~deleted_nodes = if enabled then ( let expected = Hashtbl.copy pre_current in - ReactiveSet.iter_with + StableSet.iter_with (fun expected k -> Hashtbl.remove expected (Stable.unsafe_to_value k)) expected deleted_nodes; let current_ht = copy_set_to_hashtbl current in @@ -327,11 +327,11 @@ module Invariants = struct let assert_removal_output_matches ~output_entries ~deleted_nodes ~current = if enabled then ( - let expected = Hashtbl.create (ReactiveSet.cardinal deleted_nodes) in - ReactiveSet.iter_with + let expected = Hashtbl.create (StableSet.cardinal deleted_nodes) in + StableSet.iter_with (fun expected k -> let k = Stable.unsafe_to_value k in - if not (ReactiveSet.mem current (stable_key k)) then + if not (StableSet.mem current (stable_key k)) then Hashtbl.replace expected k ()) expected deleted_nodes; let actual = Hashtbl.create (List.length output_entries) in @@ -353,9 +353,9 @@ module Invariants = struct "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; - let expected_adds = Hashtbl.create (ReactiveSet.cardinal t.current) in + let expected_adds = Hashtbl.create (StableSet.cardinal t.current) in let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in - ReactiveSet.iter_with + StableSet.iter_with (fun expected_adds k -> let k = Stable.unsafe_to_value k in if not (Hashtbl.mem pre_current k) then @@ -363,7 +363,7 @@ module Invariants = struct expected_adds t.current; Hashtbl.iter (fun k () -> - if not (ReactiveSet.mem t.current (stable_key k)) then + if not (StableSet.mem t.current (stable_key k)) then Hashtbl.replace expected_removes k ()) pre_current; @@ -384,7 +384,7 @@ module Invariants = struct (pre=%d final=%d output=%d expected_adds=%d actual_adds=%d \ expected_removes=%d actual_removes=%d)" (Hashtbl.length pre_current) - (ReactiveSet.cardinal t.current) + (StableSet.cardinal t.current) (List.length output_entries) (Hashtbl.length expected_adds) (Hashtbl.length actual_adds) @@ -398,24 +398,24 @@ let create ~max_nodes ~max_edges = if max_edges <= 0 then invalid_arg "ReactiveFixpoint.create: max_edges must be > 0"; { - current = ReactiveSet.create (); - edge_map = ReactiveMap.create (); + current = StableSet.create (); + edge_map = StableMap.create (); pred_map = ReactivePoolMapSet.create ~capacity:128; - roots = ReactiveSet.create (); + roots = StableSet.create (); output_wave = ReactiveWave.create ~max_entries:max_nodes (); - deleted_nodes = ReactiveSet.create (); - rederive_pending = ReactiveSet.create (); - expansion_seen = ReactiveSet.create (); - old_successors_for_changed = ReactiveMap.create (); - scratch_set_a = ReactiveSet.create (); - scratch_set_b = ReactiveSet.create (); - edge_has_new = ReactiveSet.create (); + 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 = ReactiveMap.create (); + new_successors_for_changed = StableMap.create (); metrics = { delete_queue_pops = 0; @@ -425,28 +425,28 @@ let create ~max_nodes ~max_edges = rederive_edges_scanned = 0; expansion_queue_pops = 0; expansion_edges_scanned = 0; - scratch_reachable = ReactiveSet.create (); + scratch_reachable = StableSet.create (); }; } let destroy t = - ReactiveSet.destroy t.current; - ReactiveMap.destroy t.edge_map; - ReactiveSet.destroy t.roots; - ReactiveSet.destroy t.deleted_nodes; - ReactiveSet.destroy t.rederive_pending; - ReactiveSet.destroy t.expansion_seen; - ReactiveMap.destroy t.old_successors_for_changed; - ReactiveMap.destroy t.new_successors_for_changed; - ReactiveSet.destroy t.scratch_set_a; - ReactiveSet.destroy t.scratch_set_b; - ReactiveSet.destroy t.edge_has_new; + StableSet.destroy t.current; + StableMap.destroy t.edge_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; - ReactiveSet.destroy t.metrics.scratch_reachable; + StableSet.destroy t.metrics.scratch_reachable; ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave @@ -457,12 +457,12 @@ type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t let iter_current t f = - ReactiveSet.iter_with (fun f k -> f (Stable.unsafe_to_value k) ()) f t.current + StableSet.iter_with (fun f k -> f (Stable.unsafe_to_value k) ()) f t.current let get_current t k = - if ReactiveSet.mem t.current (stable_key k) then Maybe.some () else Maybe.none + if StableSet.mem t.current (stable_key k) then Maybe.some () else Maybe.none -let current_length t = ReactiveSet.cardinal t.current +let current_length t = StableSet.cardinal t.current let recompute_current t = ignore (compute_reachable ~visited:t.current t) @@ -471,7 +471,7 @@ let add_pred t ~target ~pred = ReactivePoolMapSet.add t.pred_map target pred let remove_pred t ~target ~pred = ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred -let has_live_pred_key t pred = ReactiveSet.mem t.current (stable_key pred) +let has_live_pred_key t pred = StableSet.mem t.current (stable_key pred) let has_live_predecessor t k = let r = ReactivePoolMapSet.find_maybe t.pred_map k in @@ -483,107 +483,107 @@ 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 r = ReactiveMap.find_maybe t.edge_map (stable_key src) in + let r = StableMap.find_maybe t.edge_map (stable_key src) in let old_successors = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in if StableList.is_empty old_successors && StableList.is_empty new_successors - then ReactiveMap.remove t.edge_map (stable_key src) + then StableMap.remove t.edge_map (stable_key src) else if StableList.is_empty old_successors then ( StableList.iter_with add_pred_for_src (t, src) new_successors; - ReactiveMap.replace t.edge_map (stable_key src) new_successors) + StableMap.replace t.edge_map (stable_key src) new_successors) else if StableList.is_empty new_successors then ( StableList.iter_with remove_pred_for_src (t, src) old_successors; - ReactiveMap.remove t.edge_map (stable_key src)) + StableMap.remove t.edge_map (stable_key src)) else ( - ReactiveSet.clear t.scratch_set_a; - ReactiveSet.clear t.scratch_set_b; + StableSet.clear t.scratch_set_a; + StableSet.clear t.scratch_set_b; StableList.iter - (fun k -> ReactiveSet.add t.scratch_set_a (stable_key k)) + (fun k -> StableSet.add t.scratch_set_a (stable_key k)) new_successors; StableList.iter - (fun k -> ReactiveSet.add t.scratch_set_b (stable_key k)) + (fun k -> StableSet.add t.scratch_set_b (stable_key k)) old_successors; StableList.iter_with (fun () target -> - if not (ReactiveSet.mem t.scratch_set_a (stable_key target)) then + if not (StableSet.mem t.scratch_set_a (stable_key target)) then remove_pred t ~target ~pred:src) () old_successors; StableList.iter_with (fun () target -> - if not (ReactiveSet.mem t.scratch_set_b (stable_key target)) then + if not (StableSet.mem t.scratch_set_b (stable_key target)) then add_pred t ~target ~pred:src) () new_successors; - ReactiveMap.replace t.edge_map (stable_key src) new_successors) + StableMap.replace t.edge_map (stable_key src) new_successors) let initialize t ~roots ~edges = - ReactiveSet.clear t.roots; - ReactiveMap.clear t.edge_map; + StableSet.clear t.roots; + StableMap.clear t.edge_map; ReactivePoolMapSet.clear t.pred_map; - ReactiveWave.iter roots (fun k _ -> ReactiveSet.add t.roots k); + ReactiveWave.iter roots (fun k _ -> StableSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> apply_edge_update t ~src:(Stable.unsafe_to_value k) ~new_successors:(StableList.of_stable_list successors)); recompute_current t let is_supported t k = - ReactiveSet.mem t.roots (stable_key k) || has_live_predecessor t k + StableSet.mem t.roots (stable_key k) || has_live_predecessor t k let old_successors t k = - let r = ReactiveMap.find_maybe t.old_successors_for_changed (stable_key k) in + let r = StableMap.find_maybe t.old_successors_for_changed (stable_key k) in if Maybe.is_some r then Maybe.unsafe_get r else - let r2 = ReactiveMap.find_maybe t.edge_map (stable_key k) in + let r2 = StableMap.find_maybe t.edge_map (stable_key k) in if Maybe.is_some r2 then Maybe.unsafe_get r2 else StableList.empty () let mark_deleted t k = if - ReactiveSet.mem t.current (stable_key k) - && not (ReactiveSet.mem t.deleted_nodes (stable_key k)) + StableSet.mem t.current (stable_key k) + && not (StableSet.mem t.deleted_nodes (stable_key k)) then ( - ReactiveSet.add t.deleted_nodes (stable_key k); + StableSet.add t.deleted_nodes (stable_key k); enqueue t.delete_queue k) let enqueue_expand t k = if - ReactiveSet.mem t.current (stable_key k) - && not (ReactiveSet.mem t.expansion_seen (stable_key k)) + StableSet.mem t.current (stable_key k) + && not (StableSet.mem t.expansion_seen (stable_key k)) then ( - ReactiveSet.add t.expansion_seen (stable_key k); + StableSet.add t.expansion_seen (stable_key k); enqueue t.expansion_queue k) let add_live t k = - if not (ReactiveSet.mem t.current (stable_key k)) then ( - ReactiveSet.add t.current (stable_key k); - if not (ReactiveSet.mem t.deleted_nodes (stable_key k)) then + if not (StableSet.mem t.current (stable_key k)) then ( + StableSet.add t.current (stable_key k); + if not (StableSet.mem t.deleted_nodes (stable_key k)) then ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) (Maybe.maybe_unit_to_stable (Maybe.some ())); enqueue_expand t k) let enqueue_rederive_if_needed t k = if - ReactiveSet.mem t.deleted_nodes (stable_key k) - && (not (ReactiveSet.mem t.current (stable_key k))) - && (not (ReactiveSet.mem t.rederive_pending (stable_key k))) + StableSet.mem t.deleted_nodes (stable_key k) + && (not (StableSet.mem t.current (stable_key k))) + && (not (StableSet.mem t.rederive_pending (stable_key k))) && is_supported t k then ( - ReactiveSet.add t.rederive_pending (stable_key k); + StableSet.add t.rederive_pending (stable_key k); enqueue t.rederive_queue k) let scan_root_entry t k mv = - let had_root = ReactiveSet.mem t.roots (stable_key k) in + let had_root = StableSet.mem t.roots (stable_key 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 set_add_k set k = ReactiveSet.add set (stable_key k) +let set_add_k set k = StableSet.add set (stable_key k) let mark_deleted_if_absent (t, set) k = - if not (ReactiveSet.mem set (stable_key k)) then mark_deleted t k + if not (StableSet.mem set (stable_key k)) then mark_deleted t k -let not_in_set set k = not (ReactiveSet.mem set (stable_key k)) +let not_in_set set k = not (StableSet.mem set (stable_key k)) let mark_deleted_unless_in_set t set xs = StableList.iter_with mark_deleted_if_absent (t, set) xs @@ -591,44 +591,44 @@ let mark_deleted_unless_in_set 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 r = ReactiveMap.find_maybe t.edge_map (stable_key src) in + let r = StableMap.find_maybe t.edge_map (stable_key src) in let old_succs = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in let new_succs = if Maybe.is_some mv then Maybe.unsafe_get mv else StableList.empty () in - ReactiveMap.replace t.old_successors_for_changed (stable_key src) old_succs; - ReactiveMap.replace t.new_successors_for_changed (stable_key src) new_succs; + StableMap.replace t.old_successors_for_changed (stable_key src) old_succs; + StableMap.replace t.new_successors_for_changed (stable_key src) new_succs; enqueue t.edge_change_queue src; - let src_is_live = ReactiveSet.mem t.current (stable_key src) in + let src_is_live = StableSet.mem t.current (stable_key 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 -> - ReactiveSet.add t.edge_has_new (stable_key src) + StableSet.add t.edge_has_new (stable_key src) | _ when StableList.is_empty new_succs -> if src_is_live then StableList.iter_with mark_deleted t old_succs | _ -> - ReactiveSet.clear t.scratch_set_a; - ReactiveSet.clear t.scratch_set_b; + 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 - ReactiveSet.add t.edge_has_new (stable_key src) + StableSet.add t.edge_has_new (stable_key src) let apply_root_mutation t k mv = - if Maybe.is_some mv then ReactiveSet.add t.roots (stable_key k) - else ReactiveSet.remove t.roots (stable_key k) + if Maybe.is_some mv then StableSet.add t.roots (stable_key k) + else StableSet.remove t.roots (stable_key k) let emit_removal t k () = - if not (ReactiveSet.mem t.current (stable_key k)) then + if not (StableSet.mem t.current (stable_key k)) then ReactiveWave.push t.output_wave (Stable.unsafe_of_value 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 = ReactiveSet.remove t.current k +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 @@ -638,13 +638,13 @@ let apply_list t ~roots ~edges = else None in (* Clear all scratch state up front *) - ReactiveSet.clear t.deleted_nodes; + StableSet.clear t.deleted_nodes; StableQueue.clear t.delete_queue; StableQueue.clear t.added_roots_queue; StableQueue.clear t.edge_change_queue; - ReactiveMap.clear t.old_successors_for_changed; - ReactiveMap.clear t.new_successors_for_changed; - ReactiveSet.clear t.edge_has_new; + 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; @@ -697,7 +697,7 @@ let apply_list t ~roots ~edges = (* 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 r = ReactiveMap.find_maybe t.new_successors_for_changed src in + let r = StableMap.find_maybe t.new_successors_for_changed src in let new_succs = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in @@ -707,9 +707,9 @@ let apply_list t ~roots ~edges = done; (* Rebuild edge_change_queue from new_successors_for_changed keys for use in expansion seeding below *) - ReactiveMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; + StableMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; - ReactiveSet.iter_with remove_from_current t t.deleted_nodes; + StableSet.iter_with remove_from_current t t.deleted_nodes; (match pre_current with | Some pre -> Invariants.assert_current_minus_deleted ~pre_current:pre ~current:t.current @@ -718,24 +718,24 @@ let apply_list t ~roots ~edges = (* Phase 4: rederive *) StableQueue.clear t.rederive_queue; - ReactiveSet.clear t.rederive_pending; + StableSet.clear t.rederive_pending; - ReactiveSet.iter_with + StableSet.iter_with (fun t k -> enqueue_rederive_if_needed_kv t (Stable.unsafe_to_value k)) t t.deleted_nodes; 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; - ReactiveSet.remove t.rederive_pending k; + StableSet.remove t.rederive_pending k; if - ReactiveSet.mem t.deleted_nodes k - && (not (ReactiveSet.mem t.current k)) + StableSet.mem t.deleted_nodes k + && (not (StableSet.mem t.current k)) && is_supported t (Stable.unsafe_to_value k) then ( - ReactiveSet.add t.current k; + StableSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; - let r = ReactiveMap.find_maybe t.edge_map k in + let r = StableMap.find_maybe t.edge_map k in if Maybe.is_some r then ( let succs = Maybe.unsafe_get r in if Metrics.enabled then @@ -749,7 +749,7 @@ let apply_list t ~roots ~edges = (* Phase 5: expansion *) StableQueue.clear t.expansion_queue; - ReactiveSet.clear t.expansion_seen; + StableSet.clear t.expansion_seen; (* Seed expansion from added roots *) while not (StableQueue.is_empty t.added_roots_queue) do @@ -759,14 +759,14 @@ let apply_list t ~roots ~edges = (* 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 ReactiveSet.mem t.current src && ReactiveSet.mem t.edge_has_new src then + if StableSet.mem t.current src && StableSet.mem t.edge_has_new src then enqueue_expand t (Stable.unsafe_to_value 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 = ReactiveMap.find_maybe t.edge_map k in + let r = StableMap.find_maybe t.edge_map k in if Maybe.is_some r then ( let succs = Maybe.unsafe_get r in if Metrics.enabled then @@ -774,7 +774,7 @@ let apply_list t ~roots ~edges = m.expansion_edges_scanned + StableList.length succs; StableList.iter_with add_live t succs) done; - ReactiveSet.iter_with + StableSet.iter_with (fun t k -> emit_removal t (Stable.unsafe_to_value k) ()) t t.deleted_nodes; let output_entries_list = @@ -811,7 +811,7 @@ let apply_list t ~roots ~edges = in Metrics.update ~init_entries:init_count ~edge_entries:edge_count ~output_entries:(ReactiveWave.count t.output_wave) - ~deleted_nodes:(ReactiveSet.cardinal t.deleted_nodes) + ~deleted_nodes:(StableSet.cardinal t.deleted_nodes) ~rederived_nodes:m.rederived_nodes ~incr_node_work ~incr_edge_work ~full_node_work ~full_edge_work diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 085a03eacda..d58e4ba220a 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -6,10 +6,10 @@ type ('k1, 'v1, 'k2, 'v2) t = { (* Persistent state *) provenance: ('k1, 'k2) ReactivePoolMapSet.t; contributions: ('k2, 'k1, 'v2) ReactivePoolMapMap.t; - target: ('k2, 'v2) ReactiveMap.t; + target: ('k2, 'v2) StableMap.t; (* Scratch — allocated once, cleared per process() *) - scratch: ('k1, 'v1 Maybe.t) ReactiveMap.t; - affected: 'k2 ReactiveSet.t; + scratch: ('k1, 'v1 Maybe.t) StableMap.t; + affected: 'k2 StableSet.t; (* Pre-allocated output buffer *) output_wave: ('k2, 'v2 Maybe.t) ReactiveWave.t; (* Emit callback state — allocated once, reused per entry *) @@ -35,13 +35,13 @@ and process_result = { let add_single_contribution (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveSet.add t.affected (Stable.unsafe_of_value k2) + StableSet.add t.affected (Stable.unsafe_of_value k2) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = ReactivePoolMapSet.add t.provenance t.current_k1 k2; ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; - ReactiveMap.replace t.target + StableMap.replace t.target (Stable.unsafe_of_value k2) (Stable.unsafe_of_value v2) @@ -52,9 +52,9 @@ let create ~f ~merge = merge; provenance = ReactivePoolMapSet.create ~capacity:128; contributions = ReactivePoolMapMap.create ~capacity:128; - target = ReactiveMap.create (); - scratch = ReactiveMap.create (); - affected = ReactiveSet.create (); + target = StableMap.create (); + scratch = StableMap.create (); + affected = StableSet.create (); output_wave = ReactiveWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k2 v2 -> add_single_contribution t k2 v2); @@ -74,20 +74,20 @@ let create ~f ~merge = t let destroy t = - ReactiveMap.destroy t.target; - ReactiveMap.destroy t.scratch; - ReactiveSet.destroy t.affected; + StableMap.destroy t.target; + StableMap.destroy t.scratch; + StableSet.destroy t.affected; ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -let push t k v_opt = ReactiveMap.replace t.scratch k v_opt +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 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 t.current_k1; - ReactiveSet.add t.affected (Stable.unsafe_of_value k2) + StableSet.add t.affected (Stable.unsafe_of_value k2) let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; @@ -106,14 +106,14 @@ let recompute_target (t : (_, _, _, _) t) k2 = t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; - ReactiveMap.replace t.target + StableMap.replace t.target (Stable.unsafe_of_value k2) (Stable.unsafe_of_value t.merge_acc); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k2) (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (Stable.unsafe_of_value k2); + StableMap.remove t.target (Stable.unsafe_of_value k2); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k2) Maybe.none_stable) @@ -144,13 +144,13 @@ let process (t : (_, _, _, _) t) = r.adds_emitted <- 0; r.removes_emitted <- 0; - ReactiveSet.clear t.affected; + StableSet.clear t.affected; ReactiveWave.clear t.output_wave; - ReactiveMap.iter_with process_scratch_entry t t.scratch; - ReactiveMap.clear t.scratch; + StableMap.iter_with process_scratch_entry t t.scratch; + StableMap.clear t.scratch; - ReactiveSet.iter_with recompute_target t t.affected; + StableSet.iter_with recompute_target t t.affected; let num_entries = ReactiveWave.count t.output_wave in r.entries_emitted <- num_entries; @@ -163,14 +163,14 @@ let init_entry (t : (_, _, _, _) t) k1 v1 = t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) let iter_target f t = - ReactiveMap.iter + StableMap.iter (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option + StableMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option |> function | Some v -> Maybe.some (Stable.unsafe_to_value v) | None -> Maybe.none -let target_length t = ReactiveMap.cardinal t.target +let target_length t = StableMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 4a005902f89..c6d135ea5c8 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -6,16 +6,16 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { merge: 'v3 -> 'v3 -> 'v3; right_get: 'k2 -> 'v2 Maybe.t; (* Persistent state *) - left_entries: ('k1, 'v1) ReactiveMap.t; + left_entries: ('k1, 'v1) StableMap.t; provenance: ('k1, 'k3) ReactivePoolMapSet.t; contributions: ('k3, 'k1, 'v3) ReactivePoolMapMap.t; - target: ('k3, 'v3) ReactiveMap.t; - left_to_right_key: ('k1, 'k2) ReactiveMap.t; + target: ('k3, 'v3) StableMap.t; + left_to_right_key: ('k1, 'k2) StableMap.t; right_key_to_left_keys: ('k2, 'k1) ReactivePoolMapSet.t; (* Scratch — allocated once, cleared per process() *) - left_scratch: ('k1, 'v1 Maybe.t) ReactiveMap.t; - right_scratch: ('k2, 'v2 Maybe.t) ReactiveMap.t; - affected: 'k3 ReactiveSet.t; + 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) ReactiveWave.t; (* Emit callback state — allocated once, reused per entry *) @@ -41,13 +41,13 @@ and process_result = { let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveSet.add t.affected (Stable.unsafe_of_value k3) + StableSet.add t.affected (Stable.unsafe_of_value k3) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = ReactivePoolMapSet.add t.provenance t.current_k1 k3; ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; - ReactiveMap.replace t.target + StableMap.replace t.target (Stable.unsafe_of_value k3) (Stable.unsafe_of_value v3) @@ -58,15 +58,15 @@ let create ~key_of ~f ~merge ~right_get = f; merge; right_get; - left_entries = ReactiveMap.create (); + left_entries = StableMap.create (); provenance = ReactivePoolMapSet.create ~capacity:128; contributions = ReactivePoolMapMap.create ~capacity:128; - target = ReactiveMap.create (); - left_to_right_key = ReactiveMap.create (); + target = StableMap.create (); + left_to_right_key = StableMap.create (); right_key_to_left_keys = ReactivePoolMapSet.create ~capacity:128; - left_scratch = ReactiveMap.create (); - right_scratch = ReactiveMap.create (); - affected = ReactiveSet.create (); + left_scratch = StableMap.create (); + right_scratch = StableMap.create (); + affected = StableSet.create (); output_wave = ReactiveWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k3 v3 -> add_single_contribution t k3 v3); @@ -86,25 +86,25 @@ let create ~key_of ~f ~merge ~right_get = t let destroy t = - ReactiveMap.destroy t.left_entries; - ReactiveMap.destroy t.target; - ReactiveMap.destroy t.left_to_right_key; - ReactiveMap.destroy t.left_scratch; - ReactiveMap.destroy t.right_scratch; - ReactiveSet.destroy t.affected; + StableMap.destroy t.left_entries; + StableMap.destroy t.target; + StableMap.destroy t.left_to_right_key; + StableMap.destroy t.left_scratch; + StableMap.destroy t.right_scratch; + StableSet.destroy t.affected; ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -let push_left t k v_opt = ReactiveMap.replace t.left_scratch k v_opt +let push_left t k v_opt = StableMap.replace t.left_scratch k v_opt -let push_right t k v_opt = ReactiveMap.replace t.right_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 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 t.current_k1; - ReactiveSet.add t.affected (Stable.unsafe_of_value k3) + StableSet.add t.affected (Stable.unsafe_of_value k3) let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; @@ -112,11 +112,11 @@ let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = let mb = - ReactiveMap.find_maybe t.left_to_right_key (Stable.unsafe_of_value k1) + StableMap.find_maybe t.left_to_right_key (Stable.unsafe_of_value k1) in if Maybe.is_some mb then ( let old_k2 = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - ReactiveMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); + StableMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys old_k2 k1) @@ -124,7 +124,7 @@ 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 - ReactiveMap.replace t.left_to_right_key + StableMap.replace t.left_to_right_key (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; @@ -133,7 +133,7 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = t.f k1 v1 right_val t.emit_fn let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = - ReactiveMap.remove t.left_entries (Stable.unsafe_of_value k1); + StableMap.remove t.left_entries (Stable.unsafe_of_value k1); remove_left_contributions t k1; unlink_right_key t k1 @@ -150,14 +150,14 @@ let recompute_target (t : (_, _, _, _, _, _) t) k3 = t.merge_first <- true; ReactivePoolMapMap.iter_inner_with t.contributions k3 t merge_one_contribution; - ReactiveMap.replace t.target + StableMap.replace t.target (Stable.unsafe_of_value k3) (Stable.unsafe_of_value t.merge_acc); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k3) (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( - ReactiveMap.remove t.target (Stable.unsafe_of_value k3); + StableMap.remove t.target (Stable.unsafe_of_value k3); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k3) Maybe.none_stable) @@ -170,7 +170,7 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = if Maybe.is_some mv then ( t.result.adds_received <- t.result.adds_received + 1; let v1 = Maybe.unsafe_get mv in - ReactiveMap.replace t.left_entries + StableMap.replace t.left_entries (Stable.unsafe_of_value k1) (Stable.unsafe_of_value v1); process_left_entry t k1 v1) @@ -180,7 +180,7 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = - let mb = ReactiveMap.find_maybe t.left_entries (Stable.unsafe_of_value k1) in + let mb = StableMap.find_maybe t.left_entries (Stable.unsafe_of_value k1) in if Maybe.is_some mb then process_left_entry t k1 (Stable.unsafe_to_value (Maybe.unsafe_get mb)) @@ -208,16 +208,16 @@ let process (t : (_, _, _, _, _, _) t) = r.adds_emitted <- 0; r.removes_emitted <- 0; - ReactiveSet.clear t.affected; + StableSet.clear t.affected; ReactiveWave.clear t.output_wave; - ReactiveMap.iter_with process_left_scratch_entry t t.left_scratch; - ReactiveMap.iter_with process_right_scratch_entry t t.right_scratch; + StableMap.iter_with process_left_scratch_entry t t.left_scratch; + StableMap.iter_with process_right_scratch_entry t t.right_scratch; - ReactiveMap.clear t.left_scratch; - ReactiveMap.clear t.right_scratch; + StableMap.clear t.left_scratch; + StableMap.clear t.right_scratch; - ReactiveSet.iter_with recompute_target t t.affected; + StableSet.iter_with recompute_target t t.affected; let num_entries = ReactiveWave.count t.output_wave in r.entries_emitted <- num_entries; @@ -226,11 +226,11 @@ let process (t : (_, _, _, _, _, _) t) = r let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = - ReactiveMap.replace t.left_entries + StableMap.replace t.left_entries (Stable.unsafe_of_value k1) (Stable.unsafe_of_value v1); let k2 = t.key_of k1 v1 in - ReactiveMap.replace t.left_to_right_key + StableMap.replace t.left_to_right_key (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; @@ -239,14 +239,14 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = t.f k1 v1 right_val (fun k3 v3 -> add_single_contribution_init t k3 v3) let iter_target f t = - ReactiveMap.iter + StableMap.iter (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option + StableMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option |> function | Some v -> Maybe.some (Stable.unsafe_to_value v) | None -> Maybe.none -let target_length t = ReactiveMap.cardinal t.target +let target_length t = StableMap.cardinal t.target diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml index f0e7e257481..5a43438ced1 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.ml +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -86,13 +86,11 @@ let find_inner_maybe t ko = StableHash.Map.find_maybe t.outer ko let iter_inner_with t ko ctx f = let mb = StableHash.Map.find_maybe t.outer ko in - if Maybe.is_some mb then - StableHash.Map.iter_with f ctx (Maybe.unsafe_get mb) + if Maybe.is_some mb then StableHash.Map.iter_with f ctx (Maybe.unsafe_get mb) let inner_cardinal t ko = let mb = StableHash.Map.find_maybe t.outer ko in - if Maybe.is_some mb then StableHash.Map.cardinal (Maybe.unsafe_get mb) - else 0 + if Maybe.is_some mb then StableHash.Map.cardinal (Maybe.unsafe_get mb) else 0 let outer_cardinal t = StableHash.Map.cardinal t.outer diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index 3f988af7993..bad0ce12169 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -2,12 +2,12 @@ type ('k, 'v) t = { merge: 'v -> 'v -> 'v; - left_values: ('k, 'v) ReactiveMap.t; - right_values: ('k, 'v) ReactiveMap.t; - target: ('k, 'v) ReactiveMap.t; - left_scratch: ('k, 'v Maybe.t) ReactiveMap.t; - right_scratch: ('k, 'v Maybe.t) ReactiveMap.t; - affected: 'k ReactiveSet.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) ReactiveWave.t; result: process_result; } @@ -24,12 +24,12 @@ and process_result = { let create ~merge = { merge; - left_values = ReactiveMap.create (); - right_values = ReactiveMap.create (); - target = ReactiveMap.create (); - left_scratch = ReactiveMap.create (); - right_scratch = ReactiveMap.create (); - affected = ReactiveSet.create (); + left_values = StableMap.create (); + right_values = StableMap.create (); + target = StableMap.create (); + left_scratch = StableMap.create (); + right_scratch = StableMap.create (); + affected = StableSet.create (); output_wave = ReactiveWave.create (); result = { @@ -43,19 +43,19 @@ let create ~merge = } let destroy t = - ReactiveMap.destroy t.left_values; - ReactiveMap.destroy t.right_values; - ReactiveMap.destroy t.target; - ReactiveMap.destroy t.left_scratch; - ReactiveMap.destroy t.right_scratch; - ReactiveSet.destroy t.affected; + 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; ReactiveWave.destroy t.output_wave let output_wave t = t.output_wave -let push_left t k mv = ReactiveMap.replace t.left_scratch k mv +let push_left t k mv = StableMap.replace t.left_scratch k mv -let push_right t k mv = ReactiveMap.replace t.right_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 *) @@ -65,13 +65,13 @@ let apply_left_entry t k mv = let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( - ReactiveMap.replace t.left_values (Stable.unsafe_of_value k) + StableMap.replace t.left_values (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.left_values (Stable.unsafe_of_value k); + StableMap.remove t.left_values (Stable.unsafe_of_value k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (Stable.unsafe_of_value k) + StableSet.add t.affected (Stable.unsafe_of_value k) let apply_right_entry t k mv = let k = Stable.unsafe_to_value k in @@ -79,19 +79,19 @@ let apply_right_entry t k mv = let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( - ReactiveMap.replace t.right_values (Stable.unsafe_of_value k) + StableMap.replace t.right_values (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.unsafe_get mv)); r.adds_received <- r.adds_received + 1) else ( - ReactiveMap.remove t.right_values (Stable.unsafe_of_value k); + StableMap.remove t.right_values (Stable.unsafe_of_value k); r.removes_received <- r.removes_received + 1); - ReactiveSet.add t.affected (Stable.unsafe_of_value k) + StableSet.add t.affected (Stable.unsafe_of_value k) let recompute_affected_entry t k = let k = Stable.unsafe_to_value k in let r = t.result in - let lv = ReactiveMap.find_maybe t.left_values (Stable.unsafe_of_value k) in - let rv = ReactiveMap.find_maybe t.right_values (Stable.unsafe_of_value k) in + let lv = StableMap.find_maybe t.left_values (Stable.unsafe_of_value k) in + let rv = StableMap.find_maybe t.right_values (Stable.unsafe_of_value k) in let has_left = Maybe.is_some lv in let has_right = Maybe.is_some rv in if has_left then ( @@ -101,31 +101,31 @@ let recompute_affected_entry t k = (Stable.unsafe_to_value (Maybe.unsafe_get lv)) (Stable.unsafe_to_value (Maybe.unsafe_get rv)) in - ReactiveMap.replace t.target (Stable.unsafe_of_value k) + StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value merged); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some merged))) else let v = Stable.unsafe_to_value (Maybe.unsafe_get lv) in - ReactiveMap.replace t.target (Stable.unsafe_of_value k) + StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v))) else if has_right then ( let v = Stable.unsafe_to_value (Maybe.unsafe_get rv) in - ReactiveMap.replace t.target (Stable.unsafe_of_value k) + StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v))) else ( - ReactiveMap.remove t.target (Stable.unsafe_of_value k); + StableMap.remove t.target (Stable.unsafe_of_value k); ReactiveWave.push t.output_wave (Stable.unsafe_of_value 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 = - ReactiveSet.clear t.affected; + StableSet.clear t.affected; let r = t.result in r.entries_received <- 0; r.adds_received <- 0; @@ -134,45 +134,45 @@ let process t = r.adds_emitted <- 0; r.removes_emitted <- 0; - ReactiveMap.iter_with apply_left_entry t t.left_scratch; - ReactiveMap.iter_with apply_right_entry t t.right_scratch; + StableMap.iter_with apply_left_entry t t.left_scratch; + StableMap.iter_with apply_right_entry t t.right_scratch; - ReactiveMap.clear t.left_scratch; - ReactiveMap.clear t.right_scratch; + StableMap.clear t.left_scratch; + StableMap.clear t.right_scratch; - if ReactiveSet.cardinal t.affected > 0 then ( + if StableSet.cardinal t.affected > 0 then ( ReactiveWave.clear t.output_wave; - ReactiveSet.iter_with recompute_affected_entry t t.affected); + StableSet.iter_with recompute_affected_entry t t.affected); r let init_left t k v = - ReactiveMap.replace t.left_values (Stable.unsafe_of_value k) + StableMap.replace t.left_values (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); - ReactiveMap.replace t.target (Stable.unsafe_of_value k) + StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v) let init_right t k v = - ReactiveMap.replace t.right_values (Stable.unsafe_of_value k) + StableMap.replace t.right_values (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); - let lv = ReactiveMap.find_maybe t.left_values (Stable.unsafe_of_value k) in + let lv = StableMap.find_maybe t.left_values (Stable.unsafe_of_value k) in let merged = if Maybe.is_some lv then t.merge (Stable.unsafe_to_value (Maybe.unsafe_get lv)) v else v in - ReactiveMap.replace t.target (Stable.unsafe_of_value k) + StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value merged) let iter_target f t = - ReactiveMap.iter + StableMap.iter (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) t.target let find_target t k = - ReactiveMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option + StableMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option |> function | Some v -> Maybe.some (Stable.unsafe_to_value v) | None -> Maybe.none -let target_length t = ReactiveMap.cardinal t.target +let target_length t = StableMap.cardinal t.target diff --git a/analysis/reactive/src/ReactiveMap.ml b/analysis/reactive/src/StableMap.ml similarity index 100% rename from analysis/reactive/src/ReactiveMap.ml rename to analysis/reactive/src/StableMap.ml diff --git a/analysis/reactive/src/ReactiveMap.mli b/analysis/reactive/src/StableMap.mli similarity index 100% rename from analysis/reactive/src/ReactiveMap.mli rename to analysis/reactive/src/StableMap.mli diff --git a/analysis/reactive/src/ReactiveSet.ml b/analysis/reactive/src/StableSet.ml similarity index 100% rename from analysis/reactive/src/ReactiveSet.ml rename to analysis/reactive/src/StableSet.ml diff --git a/analysis/reactive/src/ReactiveSet.mli b/analysis/reactive/src/StableSet.mli similarity index 100% rename from analysis/reactive/src/ReactiveSet.mli rename to analysis/reactive/src/StableSet.mli From de3a0b3ae9490d6dfd04638e9add86131d4fee3b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 09:35:16 +0100 Subject: [PATCH 30/54] analysis/reactive: use Stable.t consistently in collection interface Make Reactive.t's iter and get use Stable.t types, matching subscribe which already delivers Stable.t-wrapped wave values. Replace Maybe.stable_strip/stable_wrap with Maybe.to_stable/of_stable that reorder wrappers without hiding the stable boundary crossing. Make Stable.unit a constant instead of a function. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Maybe.ml | 3 ++ analysis/reactive/src/Maybe.mli | 6 ++++ analysis/reactive/src/Reactive.ml | 21 +++++++----- analysis/reactive/src/Reactive.mli | 8 ++--- .../reactive/src/ReactiveFileCollection.ml | 4 ++- analysis/reactive/src/ReactiveFixpoint.ml | 4 +-- analysis/reactive/src/ReactiveFixpoint.mli | 4 +-- analysis/reactive/src/ReactiveFlatMap.ml | 13 +++---- analysis/reactive/src/ReactiveFlatMap.mli | 7 ++-- analysis/reactive/src/ReactiveJoin.ml | 25 +++++++------- analysis/reactive/src/ReactiveJoin.mli | 13 ++++--- analysis/reactive/src/ReactiveUnion.ml | 34 +++++++------------ analysis/reactive/src/ReactiveUnion.mli | 8 ++--- analysis/reactive/src/Stable.ml | 2 +- analysis/reactive/src/Stable.mli | 4 +-- analysis/reactive/test/AllocTest.ml | 7 ++-- .../reactive/test/FixpointIncrementalTest.ml | 26 +++++++------- analysis/reactive/test/IntegrationTest.ml | 28 ++++++++++++--- analysis/reactive/test/TestHelpers.ml | 9 +++-- 19 files changed, 132 insertions(+), 94 deletions(-) diff --git a/analysis/reactive/src/Maybe.ml b/analysis/reactive/src/Maybe.ml index b27c7181e11..9afc315a472 100644 --- a/analysis/reactive/src/Maybe.ml +++ b/analysis/reactive/src/Maybe.ml @@ -27,3 +27,6 @@ let[@inline] maybe_stable_list_to_stable (x : 'a StableList.t t) : 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 index 864d9c1b5c8..9c6debbb558 100644 --- a/analysis/reactive/src/Maybe.mli +++ b/analysis/reactive/src/Maybe.mli @@ -32,3 +32,9 @@ val maybe_stable_list_to_stable : 'a StableList.t t -> 'a list t Stable.t storage in a stable container with semantic payload type ['a list]. *) 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 77607844087..4c74dc884bf 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -454,8 +454,8 @@ let rec notify_subscribers wave = function type ('k, 'v) t = { name: string; subscribe: (('k, 'v) wave -> unit) -> unit; - iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v Maybe.t; + 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; @@ -523,12 +523,19 @@ module Source = struct Registry.register_node ~name ~level:0 ~process ~destroy ~stats:my_stats in + let iter_stable f k v = + f (Stable.unsafe_of_value k) (Stable.unsafe_of_value v) + in let collection = { name; subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> StableHash.Map.iter f tbl); - get = (fun k -> StableHash.Map.find_maybe tbl k); + iter = (fun f -> StableHash.Map.iter_with iter_stable f tbl); + get = + (fun k -> + Maybe.of_stable + (Stable.unsafe_of_value + (StableHash.Map.find_maybe tbl (Stable.unsafe_to_value k)))); length = (fun () -> StableHash.Map.cardinal tbl); destroy; stats = my_stats; @@ -918,10 +925,8 @@ module Fixpoint = struct in ReactiveWave.clear init_roots_wave; ReactiveWave.clear init_edges_wave; - init.iter (fun k () -> unsafe_wave_push init_roots_wave k ()); - edges.iter (fun k succs -> - ReactiveWave.push init_edges_wave (Stable.unsafe_of_value k) - (Stable.unsafe_of_value succs)); + init.iter (fun k _unit -> ReactiveWave.push init_roots_wave k Stable.unit); + edges.iter (fun k succs -> ReactiveWave.push init_edges_wave k succs); ReactiveFixpoint.initialize state ~roots:init_roots_wave ~edges:init_edges_wave; ReactiveWave.destroy init_roots_wave; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index 6b8282946de..db0d6f24fdd 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -75,8 +75,8 @@ end type ('k, 'v) t = { name: string; subscribe: (('k, 'v) wave -> unit) -> unit; - iter: ('k -> 'v -> unit) -> unit; - get: 'k -> 'v Maybe.t; + 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; @@ -85,8 +85,8 @@ type ('k, 'v) t = { } (** 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 Maybe.t +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 diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index 51c22cbc89a..a6671f081e2 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -123,4 +123,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.unsafe_to_value k) (Stable.unsafe_to_value v)) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 8f189adbccb..257decd4300 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -457,10 +457,10 @@ type 'k root_snapshot = ('k, unit) ReactiveWave.t type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t let iter_current t f = - StableSet.iter_with (fun f k -> f (Stable.unsafe_to_value k) ()) f t.current + StableSet.iter_with (fun f k -> f k Stable.unit) f t.current let get_current t k = - if StableSet.mem t.current (stable_key k) then Maybe.some () else Maybe.none + if StableSet.mem t.current k then Maybe.some Stable.unit else Maybe.none let current_length t = StableSet.cardinal t.current diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 3f58d1853e6..8f4966b0cca 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -21,8 +21,8 @@ val destroy : 'k t -> unit val output_wave : 'k t -> 'k output_wave (** The owned output wave populated by [apply_wave]. *) -val iter_current : 'k t -> ('k -> unit -> unit) -> unit -val get_current : 'k t -> 'k -> unit Maybe.t +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 val initialize : diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index d58e4ba220a..f8388db9955 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -159,18 +159,13 @@ let process (t : (_, _, _, _) t) = r let init_entry (t : (_, _, _, _) t) k1 v1 = + let k1 = Stable.unsafe_to_value k1 in + let v1 = Stable.unsafe_to_value v1 in t.current_k1 <- k1; t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) -let iter_target f t = - StableMap.iter - (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) - t.target +let iter_target f t = StableMap.iter f t.target -let find_target t k = - StableMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option - |> function - | Some v -> Maybe.some (Stable.unsafe_to_value v) - | None -> Maybe.none +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 index 66920237485..8e1d13d7829 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -34,9 +34,10 @@ val process : ('k1, 'v1, 'k2, 'v2) t -> process_result 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 -> 'v1 -> unit +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 -> 'v2 -> unit) -> ('k1, 'v1, 'k2, 'v2) t -> unit -val find_target : ('k1, 'v1, 'k2, 'v2) t -> 'k2 -> 'v2 Maybe.t +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 index c6d135ea5c8..6038bddd761 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -4,7 +4,7 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { key_of: 'k1 -> 'v1 -> 'k2; f: 'k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit; merge: 'v3 -> 'v3 -> 'v3; - right_get: 'k2 -> 'v2 Maybe.t; + right_get: 'k2 Stable.t -> 'v2 Stable.t Maybe.t; (* Persistent state *) left_entries: ('k1, 'v1) StableMap.t; provenance: ('k1, 'k3) ReactivePoolMapSet.t; @@ -128,7 +128,10 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; - let right_val = t.right_get k2 in + let right_val = + Stable.unsafe_to_value + (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) + in t.current_k1 <- k1; t.f k1 v1 right_val t.emit_fn @@ -226,6 +229,8 @@ let process (t : (_, _, _, _, _, _) t) = r let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = + let k1 = Stable.unsafe_to_value k1 in + let v1 = Stable.unsafe_to_value v1 in StableMap.replace t.left_entries (Stable.unsafe_of_value k1) (Stable.unsafe_of_value v1); @@ -234,19 +239,15 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; - let right_val = t.right_get k2 in + let right_val = + Stable.unsafe_to_value + (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) + in t.current_k1 <- k1; t.f k1 v1 right_val (fun k3 v3 -> add_single_contribution_init t k3 v3) -let iter_target f t = - StableMap.iter - (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) - t.target +let iter_target f t = StableMap.iter f t.target -let find_target t k = - StableMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option - |> function - | Some v -> Maybe.some (Stable.unsafe_to_value v) - | None -> Maybe.none +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 index 376d934b5e0..6cc84434b07 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -17,7 +17,7 @@ val create : key_of:('k1 -> 'v1 -> 'k2) -> f:('k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> merge:('v3 -> 'v3 -> 'v3) -> - right_get:('k2 -> 'v2 Maybe.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 @@ -47,10 +47,15 @@ val process : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> process_result 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 -> 'v1 -> unit +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 -> 'v3 -> unit) -> ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit -val find_target : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> 'k3 -> 'v3 Maybe.t + ('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 index bad0ce12169..1befcd05f35 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -147,32 +147,24 @@ let process t = r let init_left t k v = - StableMap.replace t.left_values (Stable.unsafe_of_value k) - (Stable.unsafe_of_value v); - StableMap.replace t.target (Stable.unsafe_of_value k) - (Stable.unsafe_of_value 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 (Stable.unsafe_of_value k) - (Stable.unsafe_of_value v); - let lv = StableMap.find_maybe t.left_values (Stable.unsafe_of_value k) in + 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 (Stable.unsafe_to_value (Maybe.unsafe_get lv)) v + Stable.unsafe_of_value + (t.merge + (Stable.unsafe_to_value (Maybe.unsafe_get lv)) + (Stable.unsafe_to_value v)) else v in - StableMap.replace t.target (Stable.unsafe_of_value k) - (Stable.unsafe_of_value merged) - -let iter_target f t = - StableMap.iter - (fun k v -> f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) - t.target - -let find_target t k = - StableMap.find_maybe t.target (Stable.unsafe_of_value k) |> Maybe.to_option - |> function - | Some v -> Maybe.some (Stable.unsafe_to_value v) - | None -> Maybe.none + 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 index e0f18a8a7fd..cfa1536185b 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -34,12 +34,12 @@ val process : ('k, 'v) t -> process_result 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 -> 'v -> unit +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 -> 'v -> unit +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 -> 'v -> unit) -> ('k, 'v) t -> unit -val find_target : ('k, 'v) t -> 'k -> 'v Maybe.t +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 index 5f2dcd1b146..5286c6cda0a 100644 --- a/analysis/reactive/src/Stable.ml +++ b/analysis/reactive/src/Stable.ml @@ -6,7 +6,7 @@ external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" let unsafe_of_value x = x let unsafe_to_value x = x let int x = unsafe_of_value x -let unit 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"; diff --git a/analysis/reactive/src/Stable.mli b/analysis/reactive/src/Stable.mli index a7e0927c7ce..668f9f69386 100644 --- a/analysis/reactive/src/Stable.mli +++ b/analysis/reactive/src/Stable.mli @@ -18,8 +18,8 @@ val of_value : 'a -> 'a t val int : int -> int t (** Safely mark an [int] as suitable for stable storage. *) -val unit : unit -> unit t -(** Safely mark [()] as suitable for stable storage. *) +val unit : unit t +(** [()] as a stable value. *) val unsafe_to_value : 'a t -> 'a (** Unsafely recover a regular OCaml value from a stable-marked value. *) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 4a22c9cbbd1..5d075d8a12d 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -46,7 +46,7 @@ let test_fixpoint_alloc_n n = let state = ReactiveFixpoint.create ~max_nodes:n ~max_edges:n in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) - ReactiveWave.push root_snap (stable_int 0) (stable_unit ()); + ReactiveWave.push root_snap (stable_int 0) stable_unit; for i = 0 to n - 2 do ReactiveWave.push edge_snap (stable_int i) (Stable.of_value edge_values.(i)) done; @@ -216,7 +216,10 @@ let test_join_alloc_n n = ~f:(fun k v right_mb emit -> if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) ~merge:(fun _l r -> r) - ~right_get:(StableHash.Map.find_maybe right_tbl) + ~right_get:(fun k -> + Maybe.of_stable + (Stable.unsafe_of_value + (StableHash.Map.find_maybe right_tbl (Stable.unsafe_to_value k)))) in (* Populate: n entries on the right, n on the left *) diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/FixpointIncrementalTest.ml index 09fcbb48552..d8f97d70fe3 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -294,7 +294,7 @@ let test_fixpoint_remove_spurious_root () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (get_opt fp "b" = Some ()); @@ -302,14 +302,14 @@ let test_fixpoint_remove_spurious_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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); (* Step 3: Edge root -> a is added *) 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (get_opt fp "a" = Some ()); @@ -317,7 +317,7 @@ let test_fixpoint_remove_spurious_root () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 3); @@ -330,7 +330,7 @@ let test_fixpoint_remove_spurious_root () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); @@ -372,7 +372,7 @@ let test_fixpoint_remove_edge_entry_alternative_source () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 3); @@ -384,7 +384,7 @@ let test_fixpoint_remove_edge_entry_alternative_source () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); @@ -426,7 +426,7 @@ let test_fixpoint_remove_edge_rederivation () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 4); @@ -439,7 +439,7 @@ let test_fixpoint_remove_edge_rederivation () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) @@ -481,7 +481,7 @@ let test_fixpoint_remove_edge_entry_rederivation () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 3); @@ -493,7 +493,7 @@ let test_fixpoint_remove_edge_entry_rederivation () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s]\n" (String.concat ", " !removed); @@ -535,7 +535,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := k :: !items) fp; + iter (fun k _ -> items := Stable.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (length fp = 4); @@ -549,7 +549,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = 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.unsafe_to_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); Printf.printf "Removed: [%s], Added: [%s]\n" (String.concat ", " !removed) diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/IntegrationTest.ml index 76fe6f871da..68d92f3cedc 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -40,10 +40,20 @@ let test_file_collection () = 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.unsafe_to_value word) + (Stable.unsafe_to_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.unsafe_to_value word) + (Stable.unsafe_to_value count)) + frequent_words; (* Verify: hello=3 (2 from a + 1 from b), world=1, foo=1 *) assert (get_opt word_counts "hello" = Some 3); @@ -63,10 +73,20 @@ let test_file_collection () = 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.unsafe_to_value word) + (Stable.unsafe_to_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.unsafe_to_value word) + (Stable.unsafe_to_value count)) + frequent_words; (* Verify: hello=2 (1 from a + 1 from b), world=2, foo=1 *) assert (get_opt word_counts "hello" = Some 2); diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index e507b50c521..5bd05bd0d8e 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -123,8 +123,13 @@ let[@warning "-32"] write_lines path lines = (** {1 Maybe/option helpers} *) -(** Convert [get] result to option for test assertions *) -let get_opt t k = Maybe.to_option (get t k) +(** 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.unsafe_to_value v) + | None -> None (** {1 Common set modules} *) From c7e93c6614a31e79a8acd5587ec0f4893d9b92c4 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 13:19:20 +0100 Subject: [PATCH 31/54] analysis/reactive: eliminate unsafe_of_value for int/unit Maybe stable conversions Use Maybe.to_stable (Maybe.some (Stable.int i)) and Maybe.to_stable (Maybe.some Stable.unit) instead of Stable.unsafe_of_value (Maybe.some ...) for types known to be immediates. Also remove maybe_int_to_stable, maybe_unit_to_stable, maybe_stable_list_to_stable helpers, change Fixpoint.create edges type to use StableList.inner, and consolidate stable_edge_wave_map_replace into stable_wave_map_replace. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Maybe.ml | 10 ---- analysis/reactive/src/Maybe.mli | 10 ---- analysis/reactive/src/Reactive.ml | 17 ++---- analysis/reactive/src/Reactive.mli | 2 +- analysis/reactive/src/ReactiveFixpoint.ml | 6 +-- analysis/reactive/src/ReactiveFixpoint.mli | 2 +- analysis/reactive/test/AllocTest.ml | 62 +++++++++++----------- analysis/reactive/test/TestHelpers.ml | 6 +-- 8 files changed, 43 insertions(+), 72 deletions(-) diff --git a/analysis/reactive/src/Maybe.ml b/analysis/reactive/src/Maybe.ml index 9afc315a472..8adeecfdc5e 100644 --- a/analysis/reactive/src/Maybe.ml +++ b/analysis/reactive/src/Maybe.ml @@ -15,16 +15,6 @@ 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] maybe_int_to_stable (x : int t) : int t Stable.t = - Stable.unsafe_of_value x - -let[@inline] maybe_unit_to_stable (x : unit t) : unit t Stable.t = - Stable.unsafe_of_value x - -let[@inline] maybe_stable_list_to_stable (x : 'a StableList.t t) : - 'a list t Stable.t = - Stable.unsafe_of_value x - let[@inline] to_option (x : 'a t) : 'a option = if x != sentinel then Some (Obj.obj x) else None diff --git a/analysis/reactive/src/Maybe.mli b/analysis/reactive/src/Maybe.mli index 9c6debbb558..a4f392b1763 100644 --- a/analysis/reactive/src/Maybe.mli +++ b/analysis/reactive/src/Maybe.mli @@ -21,16 +21,6 @@ val is_none : 'a t -> bool val is_some : 'a t -> bool val unsafe_get : 'a t -> 'a -val maybe_int_to_stable : int t -> int t Stable.t -(** Safely mark an [int] maybe value as suitable for stable storage. *) - -val maybe_unit_to_stable : unit t -> unit t Stable.t -(** Safely mark a [unit] maybe value as suitable for stable storage. *) - -val maybe_stable_list_to_stable : 'a StableList.t t -> 'a list t Stable.t -(** Mark a maybe value carrying an already stable-marked list as suitable for - storage in a stable container with semantic payload type ['a list]. *) - val to_option : 'a t -> 'a option val to_stable : 'a Stable.t t -> 'a t Stable.t diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 4c74dc884bf..97b49d64f3f 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -806,19 +806,10 @@ end module Fixpoint = struct let stable_wave_map_replace pending k v = StableMap.replace pending k v - let stable_edge_wave_map_replace pending k v = - let v : _ Maybe.t = Stable.unsafe_to_value v in - let v = - if Maybe.is_some v then - Maybe.some (StableList.unsafe_inner_of_list (Maybe.unsafe_get v)) - else Maybe.none - in - StableMap.replace pending k (Stable.unsafe_of_value v) - let stable_wave_push wave k v = ReactiveWave.push wave k v - let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k list) t) () : - ('k, unit) t = + let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k StableList.inner) 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 @@ -913,14 +904,14 @@ module Fixpoint = struct edges.subscribe (fun wave -> Registry.inc_inflight_node edges.node; edges_pending_count := !edges_pending_count + 1; - ReactiveWave.iter_with wave stable_edge_wave_map_replace edge_pending; + ReactiveWave.iter_with wave stable_wave_map_replace edge_pending; Registry.mark_dirty_node my_info); (* Initialize from existing data *) let init_roots_wave = ReactiveWave.create ~max_entries:(max 1 (init.length ())) () in - let init_edges_wave : ('k, 'k list) ReactiveWave.t = + let init_edges_wave : ('k, 'k StableList.inner) ReactiveWave.t = ReactiveWave.create ~max_entries:(max 1 (edges.length ())) () in ReactiveWave.clear init_roots_wave; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index db0d6f24fdd..37ae6386d82 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -153,7 +153,7 @@ module Fixpoint : sig val create : name:string -> init:('k, unit) t -> - edges:('k, 'k list) t -> + edges:('k, 'k StableList.inner) t -> unit -> ('k, unit) t (** Compute transitive closure. diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 257decd4300..80298b10608 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -454,7 +454,7 @@ type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k edge_wave = ('k, 'k StableList.inner Maybe.t) ReactiveWave.t type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t -type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t +type 'k edge_snapshot = ('k, 'k StableList.inner) ReactiveWave.t let iter_current t f = StableSet.iter_with (fun f k -> f k Stable.unit) f t.current @@ -526,7 +526,7 @@ let initialize t ~roots ~edges = ReactiveWave.iter roots (fun k _ -> StableSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> apply_edge_update t ~src:(Stable.unsafe_to_value k) - ~new_successors:(StableList.of_stable_list successors)); + ~new_successors:successors); recompute_current t let is_supported t k = @@ -560,7 +560,7 @@ let add_live t k = StableSet.add t.current (stable_key k); if not (StableSet.mem t.deleted_nodes (stable_key k)) then ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) - (Maybe.maybe_unit_to_stable (Maybe.some ())); + (Maybe.to_stable (Maybe.some Stable.unit)); enqueue_expand t k) let enqueue_rederive_if_needed t k = diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 8f4966b0cca..b367cf4f8e7 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -7,7 +7,7 @@ type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k edge_wave = ('k, 'k StableList.inner Maybe.t) ReactiveWave.t type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t type 'k root_snapshot = ('k, unit) ReactiveWave.t -type 'k edge_snapshot = ('k, 'k list) ReactiveWave.t +type 'k edge_snapshot = ('k, 'k StableList.inner) ReactiveWave.t val create : max_nodes:int -> max_edges:int -> 'k t (** Create an empty state with fixed capacities. diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 5d075d8a12d..4393688fcf9 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -7,13 +7,8 @@ open TestHelpers let words_since = AllocMeasure.words_since -let stable = Stable.unsafe_of_value let stable_int = Stable.int let stable_unit = Stable.unit -let stable_maybe_int = Maybe.maybe_int_to_stable -let stable_maybe_unit = Maybe.maybe_unit_to_stable - -let unsafe_wave_push wave k v = ReactiveWave.push wave (stable k) (stable v) let print_stable_usage () = let blocks = Allocator.live_block_count () in @@ -48,14 +43,16 @@ let test_fixpoint_alloc_n n = (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) ReactiveWave.push root_snap (stable_int 0) stable_unit; for i = 0 to n - 2 do - ReactiveWave.push edge_snap (stable_int i) (Stable.of_value edge_values.(i)) + ReactiveWave.push edge_snap (stable_int i) + (Stable.of_value (StableList.unsafe_inner_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 *) ReactiveWave.push remove_root (stable_int 0) Maybe.none_stable; - ReactiveWave.push add_root (stable_int 0) (stable_maybe_unit (Maybe.some ())); + ReactiveWave.push add_root (stable_int 0) + (Maybe.to_stable (Maybe.some Stable.unit)); (* Warmup *) for _ = 1 to 5 do @@ -100,7 +97,8 @@ let test_flatmap_alloc_n n = (* Populate: n entries *) for i = 0 to n - 1 do - ReactiveFlatMap.push state (stable_int i) (stable_maybe_int (Maybe.some i)) + 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); @@ -108,13 +106,13 @@ let test_flatmap_alloc_n 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 i) Maybe.none_stable + 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) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveFlatMap.process state); assert (ReactiveFlatMap.target_length state = n) @@ -125,12 +123,12 @@ let test_flatmap_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveFlatMap.push state (stable i) Maybe.none_stable + 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) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveFlatMap.process state) done; @@ -157,7 +155,7 @@ let test_union_alloc_n n = (* Populate: n entries on the left side *) for i = 0 to n - 1 do ReactiveUnion.push_left state (stable_int i) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n); @@ -165,13 +163,13 @@ let test_union_alloc_n 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 i) Maybe.none_stable + 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) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveUnion.process state); assert (ReactiveUnion.target_length state = n) @@ -182,12 +180,12 @@ let test_union_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveUnion.push_left state (stable i) Maybe.none_stable + 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) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveUnion.process state) done; @@ -228,7 +226,7 @@ let test_join_alloc_n n = done; for i = 0 to n - 1 do ReactiveJoin.push_left state (stable_int i) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n); @@ -236,13 +234,13 @@ let test_join_alloc_n n = (* Warmup: toggle all left entries *) for _ = 1 to 5 do for i = 0 to n - 1 do - ReactiveJoin.push_left state (stable i) Maybe.none_stable + 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) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveJoin.process state); assert (ReactiveJoin.target_length state = n) @@ -253,12 +251,12 @@ let test_join_alloc_n n = ignore (words_since ()); for _ = 1 to iters do for i = 0 to n - 1 do - ReactiveJoin.push_left state (stable i) Maybe.none_stable + 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) - (stable_maybe_int (Maybe.some i)) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; ignore (ReactiveJoin.process state) done; @@ -305,11 +303,12 @@ let test_reactive_join_alloc_n n = (* Pre-build waves for the hot loop: toggle all left entries *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (stable i) Maybe.none_stable + ReactiveWave.push remove_wave (stable_int i) Maybe.none_stable done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - unsafe_wave_push add_wave i (Maybe.some i) + ReactiveWave.push add_wave (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; (* Warmup *) @@ -360,7 +359,7 @@ let test_reactive_fixpoint_alloc_n n = ReactiveWave.clear edge_wave; for i = 0 to n - 2 do ReactiveWave.push edge_wave (stable_int i) - (Maybe.maybe_stable_list_to_stable (Maybe.some edge_values_stable.(i))) + (Maybe.to_stable (Maybe.some edge_values_stable.(i))) done; emit_edges edge_wave; let reachable = Reactive.Fixpoint.create ~name:"reachable" ~init ~edges () in @@ -373,7 +372,8 @@ let test_reactive_fixpoint_alloc_n n = let remove_wave = ReactiveWave.create ~max_entries:1 () in ReactiveWave.push remove_wave (stable_int 0) Maybe.none_stable; let add_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push add_wave (stable_int 0) (stable_maybe_unit (Maybe.some ())); + ReactiveWave.push add_wave (stable_int 0) + (Maybe.to_stable (Maybe.some Stable.unit)); (* Warmup *) for _ = 1 to 5 do @@ -426,11 +426,12 @@ let test_reactive_union_alloc_n n = (* Pre-build waves: single wave with all n entries *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (stable i) Maybe.none_stable + ReactiveWave.push remove_wave (stable_int i) Maybe.none_stable done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - unsafe_wave_push add_wave i (Maybe.some i) + ReactiveWave.push add_wave (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; (* Warmup *) @@ -485,11 +486,12 @@ let test_reactive_flatmap_alloc_n n = (* Pre-build waves *) let remove_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (stable i) Maybe.none_stable + ReactiveWave.push remove_wave (stable_int i) Maybe.none_stable done; let add_wave = ReactiveWave.create ~max_entries:n () in for i = 0 to n - 1 do - unsafe_wave_push add_wave i (Maybe.some i) + ReactiveWave.push add_wave (stable_int i) + (Maybe.to_stable (Maybe.some (Stable.int i))) done; (* Warmup *) diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 5bd05bd0d8e..c8e49d999ad 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -26,8 +26,7 @@ let emit_edge_set emit k vs = let w = wave () in ReactiveWave.clear w; ReactiveWave.push w (Stable.unsafe_of_value k) - (Maybe.maybe_stable_list_to_stable - (Maybe.some (StableList.unsafe_of_list vs))); + (Maybe.to_stable (Maybe.some (StableList.unsafe_of_list vs))); emit w (** Emit a single remove entry *) @@ -71,8 +70,7 @@ let emit_edge_batch emit entries = match vs_opt with | Some vs -> ReactiveWave.push w (Stable.unsafe_of_value k) - (Maybe.maybe_stable_list_to_stable - (Maybe.some (StableList.unsafe_of_list vs))) + (Maybe.to_stable (Maybe.some (StableList.unsafe_of_list vs))) | None -> ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) entries; emit w From ee3a9dad0eb7212467a97ef0909f6260df5accb6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 13:34:21 +0100 Subject: [PATCH 32/54] analysis/reactive: rename StableHash back to ReactiveHash StableHash doesn't use the custom stable allocator, so the "Stable" name was misleading. Revert to the original ReactiveHash name. Co-Authored-By: Claude Opus 4.6 --- .../reactive/src/CONVERTING_COMBINATORS.md | 42 ++++++++-------- analysis/reactive/src/POOL_MAP_MAP.md | 2 +- analysis/reactive/src/Reactive.ml | 34 ++++++------- analysis/reactive/src/ReactiveFixpoint.ml | 2 +- .../src/{StableHash.ml => ReactiveHash.ml} | 0 .../src/{StableHash.mli => ReactiveHash.mli} | 0 analysis/reactive/src/ReactiveJoin.ml | 2 +- analysis/reactive/src/ReactivePoolMapMap.ml | 48 ++++++++++--------- analysis/reactive/src/ReactivePoolMapMap.mli | 2 +- analysis/reactive/src/ReactivePoolMapSet.ml | 46 +++++++++--------- analysis/reactive/src/ReactivePoolMapSet.mli | 4 +- analysis/reactive/test/AllocTest.ml | 8 ++-- 12 files changed, 96 insertions(+), 94 deletions(-) rename analysis/reactive/src/{StableHash.ml => ReactiveHash.ml} (100%) rename analysis/reactive/src/{StableHash.mli => ReactiveHash.mli} (100%) diff --git a/analysis/reactive/src/CONVERTING_COMBINATORS.md b/analysis/reactive/src/CONVERTING_COMBINATORS.md index b34086ea2d4..dc132bbe225 100644 --- a/analysis/reactive/src/CONVERTING_COMBINATORS.md +++ b/analysis/reactive/src/CONVERTING_COMBINATORS.md @@ -1,7 +1,7 @@ # 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 `StableHash` +`Reactive.ml` into its own private module backed by `ReactiveHash` (Hachis open-addressing tables), following the pattern established by `ReactiveUnion` and `ReactiveFlatMap`. @@ -83,33 +83,33 @@ capturing `t`. Use the `_with` variants to pass `t` as data: ```ocaml (* Allocates a closure capturing t: *) -StableHash.Map.iter (fun k () -> enqueue t k) m +ReactiveHash.Map.iter (fun k () -> enqueue t k) m List.iter (fun k -> mark_deleted t k) succs (* Zero allocation — t passed as data: *) -StableHash.Map.iter_with enqueue_kv t m +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 -`StableHash.Map`, `StableHash.Set`, `ReactiveWave`, and as +`ReactiveHash.Map`, `ReactiveHash.Set`, `ReactiveWave`, and as `list_iter_with` for `'a list`. ### Use `Maybe` instead of `option` for lookups -`StableHash.Map.find_maybe` returns a `Maybe.t` — an +`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 = StableHash.Map.find_maybe t.pred_map k in +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 StableHash.Map.find_opt t.pred_map k with +match ReactiveHash.Map.find_opt t.pred_map k with | Some v -> use v | None -> ... ``` @@ -122,19 +122,19 @@ When checking whether any key in map A exists in map B (e.g. ```ocaml (* Zero allocation, early-exit: *) -StableHash.Map.has_common_key pred_set current +ReactiveHash.Map.has_common_key pred_set current (* Allocates 5 words/call due to capturing closure: *) try - StableHash.Map.iter (fun k () -> - if StableHash.Map.mem current k then raise Found) pred_set; + 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 -`StableHash` stores `Obj.t` internally. The `iter` implementation +`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: @@ -192,7 +192,7 @@ for the pattern. For combinators whose `process()` runs on every scheduler wave, this means O(n) allocations per wave just for internal bookkeeping. -`StableHash` wraps Hachis, which uses open addressing with flat +`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. @@ -210,17 +210,17 @@ Add the module to `private_modules` in ### 2. Define a state type and `process_result` The state record holds all persistent tables and scratch buffers. -Use `StableHash.Map` for key-value maps and `StableHash.Set` +Use `ReactiveHash.Map` for key-value maps and `ReactiveHash.Set` for dedup sets. ```ocaml type ('k, 'v) t = { (* persistent state *) - target: ('k, 'v) StableHash.Map.t; + target: ('k, 'v) ReactiveHash.Map.t; ... (* scratch — allocated once, cleared per process() *) - scratch: ('k, 'v option) StableHash.Map.t; - affected: 'k StableHash.Set.t; + scratch: ('k, 'v option) ReactiveHash.Map.t; + affected: 'k ReactiveHash.Set.t; (* pre-allocated output buffer *) output_wave: ('k, 'v option) ReactiveWave.t; } @@ -289,13 +289,13 @@ let my_combinator ~name ... = ### 5. Key patterns to follow **Replace per-process-call allocations:** -| Old (Hashtbl) | New (StableHash) | +| 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 `StableHash.Set`, `clear` | -| `List.filter_map ... recompute_target` | `StableHash.Set.iter` + write to wave | +| `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:** @@ -332,7 +332,7 @@ make -C analysis/reactive test ### Remaining allocations in `ReactiveFixpoint` -Converted to `StableHash`: +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` @@ -351,6 +351,6 @@ Eliminated intermediate lists, records, and closures: 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 `StableHash.Map` created when a node first gains predecessors (same pattern as `contributions` in flatMap/join — allocates once per new target, then reuses). +- **`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/POOL_MAP_MAP.md b/analysis/reactive/src/POOL_MAP_MAP.md index edcbf243250..ac75e289c7e 100644 --- a/analysis/reactive/src/POOL_MAP_MAP.md +++ b/analysis/reactive/src/POOL_MAP_MAP.md @@ -92,7 +92,7 @@ val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko -> int val outer_cardinal : ('ko, 'ki, 'v) t -> int val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) StableHash.Map.t Maybe.t + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t (** Optional: keep internal/private if we want stricter discipline. *) val tighten : ('ko, 'ki, 'v) t -> unit diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 97b49d64f3f..31e85b0f979 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -478,8 +478,8 @@ let unsafe_wave_push wave k v = module Source = struct type ('k, 'v) tables = { - tbl: ('k, 'v) StableHash.Map.t; - pending: ('k, 'v Maybe.t) StableHash.Map.t; + tbl: ('k, 'v) ReactiveHash.Map.t; + pending: ('k, 'v Maybe.t) ReactiveHash.Map.t; } let apply_emit (tables : ('k, 'v) tables) k mv = @@ -487,35 +487,35 @@ module Source = struct let mv = Stable.unsafe_to_value mv in if Maybe.is_some mv then ( let v = Maybe.unsafe_get mv in - StableHash.Map.replace tables.tbl k v; - StableHash.Map.replace tables.pending k (Maybe.some v)) + ReactiveHash.Map.replace tables.tbl k v; + ReactiveHash.Map.replace tables.pending k (Maybe.some v)) else ( - StableHash.Map.remove tables.tbl k; - StableHash.Map.replace tables.pending k Maybe.none) + ReactiveHash.Map.remove tables.tbl k; + ReactiveHash.Map.replace tables.pending k Maybe.none) let create ~name () = - let tbl : ('k, 'v) StableHash.Map.t = StableHash.Map.create () in + let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.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 StableHash.Map for zero-alloc deduplication (last-write-wins). *) - let pending : ('k, 'v Maybe.t) StableHash.Map.t = - StableHash.Map.create () + Uses ReactiveHash.Map for zero-alloc deduplication (last-write-wins). *) + let pending : ('k, 'v Maybe.t) ReactiveHash.Map.t = + ReactiveHash.Map.create () in let tables = {tbl; pending} in let pending_count = ref 0 in let process () = - let count = StableHash.Map.cardinal pending in + let count = ReactiveHash.Map.cardinal pending in if count > 0 then ( my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; my_stats.entries_emitted <- my_stats.entries_emitted + count; ReactiveWave.clear output_wave; - StableHash.Map.iter_with unsafe_wave_push output_wave pending; - StableHash.Map.clear pending; + ReactiveHash.Map.iter_with unsafe_wave_push output_wave pending; + ReactiveHash.Map.clear pending; notify_subscribers output_wave !subscribers) - else StableHash.Map.clear pending + else ReactiveHash.Map.clear pending in let destroy () = ReactiveWave.destroy output_wave in @@ -530,13 +530,13 @@ module Source = struct { name; subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> StableHash.Map.iter_with iter_stable f tbl); + iter = (fun f -> ReactiveHash.Map.iter_with iter_stable f tbl); get = (fun k -> Maybe.of_stable (Stable.unsafe_of_value - (StableHash.Map.find_maybe tbl (Stable.unsafe_to_value k)))); - length = (fun () -> StableHash.Map.cardinal tbl); + (ReactiveHash.Map.find_maybe tbl (Stable.unsafe_to_value k)))); + length = (fun () -> ReactiveHash.Map.cardinal tbl); destroy; stats = my_stats; level = 0; diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 80298b10608..57f852b2ec3 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -476,7 +476,7 @@ let has_live_pred_key t pred = StableSet.mem t.current (stable_key pred) let has_live_predecessor t k = let r = ReactivePoolMapSet.find_maybe t.pred_map k in if Maybe.is_some r then - StableHash.Set.exists_with has_live_pred_key t (Maybe.unsafe_get r) + ReactiveHash.Set.exists_with has_live_pred_key t (Maybe.unsafe_get r) else false let add_pred_for_src (t, src) target = add_pred t ~target ~pred:src diff --git a/analysis/reactive/src/StableHash.ml b/analysis/reactive/src/ReactiveHash.ml similarity index 100% rename from analysis/reactive/src/StableHash.ml rename to analysis/reactive/src/ReactiveHash.ml diff --git a/analysis/reactive/src/StableHash.mli b/analysis/reactive/src/ReactiveHash.mli similarity index 100% rename from analysis/reactive/src/StableHash.mli rename to analysis/reactive/src/ReactiveHash.mli diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 6038bddd761..860581afbca 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -196,7 +196,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = else t.result.removes_received <- t.result.removes_received + 1; let mb = ReactivePoolMapSet.find_maybe t.right_key_to_left_keys k2 in if Maybe.is_some mb then - StableHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) + ReactiveHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = let mv = Stable.unsafe_to_value mv in diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml index 5a43438ced1..7e4d5c4f20b 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.ml +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -4,8 +4,8 @@ map-of-map structures. *) type ('ko, 'ki, 'v) t = { - outer: ('ko, ('ki, 'v) StableHash.Map.t) StableHash.Map.t; - mutable pool: ('ki, 'v) StableHash.Map.t array; + outer: ('ko, ('ki, 'v) ReactiveHash.Map.t) ReactiveHash.Map.t; + mutable pool: ('ki, 'v) ReactiveHash.Map.t array; mutable pool_len: int; mutable recycle_count: int; mutable miss_count: int; @@ -13,7 +13,7 @@ type ('ko, 'ki, 'v) t = { let create ~capacity:pool_capacity = { - outer = StableHash.Map.create (); + outer = ReactiveHash.Map.create (); pool = Array.make pool_capacity (Obj.magic 0); pool_len = 0; recycle_count = 0; @@ -43,57 +43,59 @@ let pool_pop t = else ( t.miss_count <- t.miss_count + 1; ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_map_miss_create; - StableHash.Map.create ()) + ReactiveHash.Map.create ()) let ensure_inner t ko = - let m = StableHash.Map.find_maybe t.outer ko in + let m = ReactiveHash.Map.find_maybe t.outer ko in if Maybe.is_some m then Maybe.unsafe_get m else let inner = pool_pop t in - StableHash.Map.replace t.outer ko inner; + ReactiveHash.Map.replace t.outer ko inner; inner let replace t ko ki v = let inner = ensure_inner t ko in - StableHash.Map.replace inner ki v + ReactiveHash.Map.replace inner ki v let remove_from_inner_and_recycle_if_empty t ko ki = - let mb = StableHash.Map.find_maybe t.outer ko in + let mb = ReactiveHash.Map.find_maybe t.outer ko in if Maybe.is_some mb then ( let inner = Maybe.unsafe_get mb in - StableHash.Map.remove inner ki; - let after = StableHash.Map.cardinal inner in + ReactiveHash.Map.remove inner ki; + let after = ReactiveHash.Map.cardinal inner in if after = 0 then ( - StableHash.Map.remove t.outer ko; - StableHash.Map.clear inner; + ReactiveHash.Map.remove t.outer ko; + ReactiveHash.Map.clear inner; pool_push t inner; t.recycle_count <- t.recycle_count + 1); ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_map_remove_recycle_if_empty) let drain_outer t ko ctx f = - let mb = StableHash.Map.find_maybe t.outer ko in + let mb = ReactiveHash.Map.find_maybe t.outer ko in if Maybe.is_some mb then ( let inner = Maybe.unsafe_get mb in - StableHash.Map.iter_with f ctx inner; - StableHash.Map.remove t.outer ko; - StableHash.Map.clear inner; + ReactiveHash.Map.iter_with f ctx inner; + ReactiveHash.Map.remove t.outer ko; + ReactiveHash.Map.clear inner; pool_push t inner; t.recycle_count <- t.recycle_count + 1; ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_map_drain_outer) -let find_inner_maybe t ko = StableHash.Map.find_maybe t.outer ko +let find_inner_maybe t ko = ReactiveHash.Map.find_maybe t.outer ko let iter_inner_with t ko ctx f = - let mb = StableHash.Map.find_maybe t.outer ko in - if Maybe.is_some mb then StableHash.Map.iter_with f ctx (Maybe.unsafe_get mb) + let mb = ReactiveHash.Map.find_maybe t.outer ko in + if Maybe.is_some mb then + ReactiveHash.Map.iter_with f ctx (Maybe.unsafe_get mb) let inner_cardinal t ko = - let mb = StableHash.Map.find_maybe t.outer ko in - if Maybe.is_some mb then StableHash.Map.cardinal (Maybe.unsafe_get mb) else 0 + let mb = ReactiveHash.Map.find_maybe t.outer ko in + if Maybe.is_some mb then ReactiveHash.Map.cardinal (Maybe.unsafe_get mb) + else 0 -let outer_cardinal t = StableHash.Map.cardinal t.outer +let outer_cardinal t = ReactiveHash.Map.cardinal t.outer -let tighten t = StableHash.Map.tighten t.outer +let tighten t = ReactiveHash.Map.tighten t.outer let debug_miss_count t = t.miss_count diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/ReactivePoolMapMap.mli index fe01d3dd02f..40394943bd5 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.mli +++ b/analysis/reactive/src/ReactivePoolMapMap.mli @@ -24,7 +24,7 @@ val drain_outer : No-op if [ko] is absent. *) val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) StableHash.Map.t Maybe.t + ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t (** Zero-allocation lookup of inner map by outer key. *) val iter_inner_with : diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml index cb444697afd..4f868828544 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.ml +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -9,8 +9,8 @@ on every source edit). *) type ('k, 'v) t = { - outer: ('k, 'v StableHash.Set.t) StableHash.Map.t; - mutable pool: 'v StableHash.Set.t array; + outer: ('k, 'v ReactiveHash.Set.t) ReactiveHash.Map.t; + mutable pool: 'v ReactiveHash.Set.t array; mutable pool_len: int; mutable recycle_count: int; mutable miss_count: int; @@ -18,7 +18,7 @@ type ('k, 'v) t = { let create ~capacity:pool_capacity = { - outer = StableHash.Map.create (); + outer = ReactiveHash.Map.create (); pool = Array.make pool_capacity (Obj.magic 0); pool_len = 0; recycle_count = 0; @@ -48,60 +48,60 @@ let pool_pop t = else ( t.miss_count <- t.miss_count + 1; ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_set_miss_create; - StableHash.Set.create ()) + ReactiveHash.Set.create ()) let ensure t k = - let m = StableHash.Map.find_maybe t.outer k in + let m = ReactiveHash.Map.find_maybe t.outer k in if Maybe.is_some m then Maybe.unsafe_get m else let set = pool_pop t in - StableHash.Map.replace t.outer k set; + ReactiveHash.Map.replace t.outer k set; set let add t k v = let set = ensure t k in - StableHash.Set.add set v + ReactiveHash.Set.add set v let drain_key t k ctx f = - let mb = StableHash.Map.find_maybe t.outer k in + let mb = ReactiveHash.Map.find_maybe t.outer k in if Maybe.is_some mb then ( let set = Maybe.unsafe_get mb in - StableHash.Set.iter_with f ctx set; - StableHash.Map.remove t.outer k; - StableHash.Set.clear set; + ReactiveHash.Set.iter_with f ctx set; + ReactiveHash.Map.remove t.outer k; + ReactiveHash.Set.clear set; pool_push t set; t.recycle_count <- t.recycle_count + 1; ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_set_drain_key) let remove_from_set_and_recycle_if_empty t k v = - let mb = StableHash.Map.find_maybe t.outer k in + let mb = ReactiveHash.Map.find_maybe t.outer k in if Maybe.is_some mb then ( let set = Maybe.unsafe_get mb in - StableHash.Set.remove set v; - let after = StableHash.Set.cardinal set in + ReactiveHash.Set.remove set v; + let after = ReactiveHash.Set.cardinal set in if after = 0 then ( - StableHash.Map.remove t.outer k; - StableHash.Set.clear set; + ReactiveHash.Map.remove t.outer k; + ReactiveHash.Set.clear set; pool_push t set; t.recycle_count <- t.recycle_count + 1); ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_set_remove_recycle_if_empty) -let find_maybe t k = StableHash.Map.find_maybe t.outer k +let find_maybe t k = ReactiveHash.Map.find_maybe t.outer k -let iter_with t ctx f = StableHash.Map.iter_with f ctx t.outer +let iter_with t ctx f = ReactiveHash.Map.iter_with f ctx t.outer let recycle_inner_set t _k set = - StableHash.Set.clear set; + ReactiveHash.Set.clear set; pool_push t set; t.recycle_count <- t.recycle_count + 1 let clear t = - StableHash.Map.iter_with recycle_inner_set t t.outer; - StableHash.Map.clear t.outer + ReactiveHash.Map.iter_with recycle_inner_set t t.outer; + ReactiveHash.Map.clear t.outer -let tighten t = StableHash.Map.tighten t.outer +let tighten t = ReactiveHash.Map.tighten t.outer -let cardinal t = StableHash.Map.cardinal t.outer +let cardinal t = ReactiveHash.Map.cardinal t.outer let debug_miss_count t = t.miss_count diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli index 3a1eea9dbcc..656358a104b 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.mli +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -20,11 +20,11 @@ val remove_from_set_and_recycle_if_empty : ('k, 'v) t -> 'k -> 'v -> unit (** [remove_from_set_and_recycle_if_empty t k v] removes [v] from [k]'s set. If the set becomes empty, [k] is recycled. No-op if [k] is absent. *) -val find_maybe : ('k, 'v) t -> 'k -> 'v StableHash.Set.t Maybe.t +val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveHash.Set.t Maybe.t (** Zero-allocation lookup. *) val iter_with : - ('k, 'v) t -> 'a -> ('a -> 'k -> 'v StableHash.Set.t -> unit) -> unit + ('k, 'v) t -> 'a -> ('a -> 'k -> 'v ReactiveHash.Set.t -> unit) -> unit (** [iter_with t ctx f] calls [f ctx k set] for each binding. *) val clear : ('k, 'v) t -> unit diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 4393688fcf9..54f7fbef03e 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -207,7 +207,7 @@ let test_union_alloc () = (* ---- Join allocation ---- *) let test_join_alloc_n n = - let right_tbl = StableHash.Map.create () in + let right_tbl = ReactiveHash.Map.create () in let state = ReactiveJoin.create ~key_of:(fun k _v -> k) @@ -217,12 +217,12 @@ let test_join_alloc_n n = ~right_get:(fun k -> Maybe.of_stable (Stable.unsafe_of_value - (StableHash.Map.find_maybe right_tbl (Stable.unsafe_to_value k)))) + (ReactiveHash.Map.find_maybe right_tbl (Stable.unsafe_to_value k)))) in (* Populate: n entries on the right, n on the left *) for i = 0 to n - 1 do - StableHash.Map.replace right_tbl i (i * 10) + ReactiveHash.Map.replace right_tbl i (i * 10) done; for i = 0 to n - 1 do ReactiveJoin.push_left state (stable_int i) @@ -534,7 +534,7 @@ let count_pool_empty_sets pms = let s = {total = 0; empty = 0} in ReactivePoolMapSet.iter_with pms s (fun st _k set -> st.total <- st.total + 1; - if StableHash.Set.cardinal set = 0 then st.empty <- st.empty + 1); + if ReactiveHash.Set.cardinal set = 0 then st.empty <- st.empty + 1); s let test_pool_map_set_pattern_drain_key_churn () = From 30e731a402413303af4844d1bc1bdaf9ff5f3624 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 15:10:22 +0100 Subject: [PATCH 33/54] analysis/reactive: simplify stable pool-map APIs --- analysis/reactive/src/POOL_MAP_MAP.md | 149 ------------------- analysis/reactive/src/POOL_MAP_SET.md | 121 --------------- analysis/reactive/src/ReactiveFixpoint.ml | 7 +- analysis/reactive/src/ReactiveFlatMap.ml | 6 +- analysis/reactive/src/ReactiveJoin.ml | 13 +- analysis/reactive/src/ReactivePoolMapMap.ml | 119 ++++++--------- analysis/reactive/src/ReactivePoolMapMap.mli | 31 ++-- analysis/reactive/src/ReactivePoolMapSet.ml | 127 +++++----------- analysis/reactive/src/ReactivePoolMapSet.mli | 37 ++--- 9 files changed, 135 insertions(+), 475 deletions(-) delete mode 100644 analysis/reactive/src/POOL_MAP_MAP.md delete mode 100644 analysis/reactive/src/POOL_MAP_SET.md diff --git a/analysis/reactive/src/POOL_MAP_MAP.md b/analysis/reactive/src/POOL_MAP_MAP.md deleted file mode 100644 index ac75e289c7e..00000000000 --- a/analysis/reactive/src/POOL_MAP_MAP.md +++ /dev/null @@ -1,149 +0,0 @@ -# ReactivePoolMapMap: Design Draft (from production lessons) - -## Why this exists - -`ReactivePoolMapSet` removed important churn footguns for `Map>`. -We still have `Map>` shapes in reactive internals with similar risks: - -- per-key inner container allocation/discovery, -- empty inner maps lingering unless callers remember to remove them, -- fragmentation pressure split across many independently sized inners. - -Goal: centralize lifecycle/recycling for inner maps, so callers cannot accidentally leak empty inners or bypass reuse. - -## Inventory of current map-of-map usage - -### 1) `ReactiveFlatMap.contributions` - -File: `ReactiveFlatMap.ml` - -Shape: - -- outer key: `k2` (derived key) -- inner key: `k1` (source key) -- value: `v2` (contribution payload) - -Ops pattern: - -- add/update one inner entry (`k2`,`k1`) frequently, -- remove one inner entry on source churn, -- recompute aggregate by iterating inner map for one `k2`, -- if inner becomes empty, target is removed. - -Current footgun: empty inner contribution maps are not always removed/recycled by construction. - -### 2) `ReactiveJoin.contributions` - -File: `ReactiveJoin.ml` - -Same shape and lifecycle as flatMap: - -- outer key: `k3` -- inner key: `k1` -- value: `v3` - -### 3) `ReactiveFixpoint.pred_map` - -File: `ReactiveFixpoint.ml` - -Type is map-of-map (`k -> (pred -> unit)`), but semantically this is map-of-set. -This likely belongs on `ReactivePoolMapSet` (or equivalent set API helpers), not a generic map-of-map API. - -## Design constraints carried from PoolMapSet - -1. Public API must encode correct teardown semantics. - -- Avoid exposing mutable inner map handles as a normal path. -- Prefer operation names that force recycling decisions. - -2. Keep diagnostics first-class. - -- Track miss and pool-resize independently. -- Request-attributed trace events for realistic replay analysis. - -3. Validate with realistic replay, then encode budgets in tests. - -- As with PoolMapSet, startup and steady-state must be analyzed separately. -- Tests should assert post-warmup miss deltas for typical churn patterns. - -## Proposed minimal API (v0 draft) - -```ocaml -type ('ko, 'ki, 'v) t - -val create : capacity:int -> ('ko, 'ki, 'v) t - -val replace : ('ko, 'ki, 'v) t -> 'ko -> 'ki -> 'v -> unit -(** Ensure inner map for outer key and set one entry. *) - -val remove_from_inner_and_recycle_if_empty : - ('ko, 'ki, 'v) t -> 'ko -> 'ki -> unit -(** Remove one inner entry; recycle and remove outer key if inner becomes empty. *) - -val drain_outer : - ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit -(** Iterate all entries for one outer key, then recycle that inner map. *) - -val iter_inner_with : - ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit -(** Read-only iteration for one outer key without exposing mutable inner map. *) - -val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko -> int -val outer_cardinal : ('ko, 'ki, 'v) t -> int - -val find_inner_maybe : - ('ko, 'ki, 'v) t -> 'ko -> ('ki, 'v) ReactiveHash.Map.t Maybe.t -(** Optional: keep internal/private if we want stricter discipline. *) - -val tighten : ('ko, 'ki, 'v) t -> unit - -val debug_miss_count : ('ko, 'ki, 'v) t -> int -``` - -## Why this API shape - -- `replace` + `remove_from_inner_and_recycle_if_empty` is the map-of-map analog of the safe PoolMapSet pair. -- `drain_outer` provides the whole-key teardown fast path. -- `iter_inner_with` avoids the main footgun: callers mutating inner maps directly and bypassing recycle. - -## Instrumentation (draft) - -Emitted event names in `ReactiveAllocTrace`: - -- `pool_map_resize` -- `pool_map_miss_create` -- `pool_map_drain_outer` -- `pool_map_remove_recycle_if_empty` - -The replay script should summarize miss/create vs pool-resize separately (same as PoolMapSet). - -## Migration status - -- Implemented: `ReactivePoolMapMap` module (API-aligned with this draft). -- Implemented: `ReactiveFlatMap.contributions` migrated to `ReactivePoolMapMap`. -- Implemented: `ReactiveJoin.contributions` migrated to `ReactivePoolMapMap`. -- Implemented decision: `ReactiveFixpoint.pred_map` migrated to - `ReactivePoolMapSet` (semantic map-of-set), not `ReactivePoolMapMap`. - -## Initial migration targets - -1. `ReactiveFlatMap.contributions` - -- Replace ad-hoc `get_contributions + Map.remove` with PoolMapMap operations. -- Ensure per-source removal path always uses `remove_from_inner_and_recycle_if_empty`. - -2. `ReactiveJoin.contributions` - -- Same migration pattern as flatMap. - -3. `ReactiveFixpoint.pred_map` - -- Done: migrated to `ReactivePoolMapSet` (map-of-set semantics). - -## Test plan (mirrors PoolMapSet) - -- Add allocation tests that mimic actual flatMap/join churn (not synthetic random patterns). -- Assert in measured phase: - - pool-map miss delta is zero for stable-key churn, - - functional result matches baseline, - - optional: bounded pool-map resize events after warmup. diff --git a/analysis/reactive/src/POOL_MAP_SET.md b/analysis/reactive/src/POOL_MAP_SET.md deleted file mode 100644 index c43ecf5f392..00000000000 --- a/analysis/reactive/src/POOL_MAP_SET.md +++ /dev/null @@ -1,121 +0,0 @@ -# ReactivePoolMapSet: Production Notes and API Guidance - -## Purpose - -`ReactivePoolMapSet` implements a pooled `Map>` for churn-heavy paths -(`flatMap` provenance and `join` provenance/reverse index). - -Goal: reduce allocation from nested-structure churn by recycling inner sets. - -## Current Public API (single API) - -- `create ~capacity` -- `add` -- `drain_key` -- `remove_from_set_and_recycle_if_empty` -- `find_maybe` -- `iter_with` -- `clear` -- `tighten` -- `cardinal` -- `debug_miss_count` (diagnostics/tests) - -`ensure` is intentionally internal. - -## Semantics that matter - -- `add` on an absent key: - - reuses a set from pool if available, - - otherwise allocates a fresh set (`pool_set_miss_create`). -- `drain_key`: - - iterates values for one key, - - removes key from outer map, - - clears and recycles the set. -- `remove_from_set_and_recycle_if_empty`: - - removes one value, - - recycles the set only if it becomes empty. -- Pool grows on demand (`pool_set_resize`) when recycled-set stack is full. - -## What we measured on real workload - -Experiment: full hyperindex replay (`benchmark/rescript-baseline..benchmark/rescript-followup`, 56 commits), reactive-only, request-attributed allocation log. - -Observed from `alloc-events.log`: - -- Startup phase (before first request): - - 331 alloc events (`map_create`, `set_create` only). -- Request phase totals: - - `pool_set_miss_create`: 31,963 - - `pool_set_resize`: 63 - - `pool_set_drain_key`: 542,071 - - `pool_set_remove_recycle_if_empty`: 544,768 -- Misses are heavily front-loaded: - - request 1: 31,825 misses - - requests 2..56 combined: 138 misses (~0.43% of total misses) -- Resizes are non-zero after warmup: - - 63 total (`join.right_key_to_left_keys`: 29, `join.provenance`: 18, `flatmap.provenance`: 16) - -Takeaway: recycling dominates steady state; late allocations exist but are small for misses and non-zero for pool-stack growth. - -## Best practices (from production replay) - -1. Use only churn-safe teardown operations. - -- For whole-key teardown: `drain_key`. -- For inverse-index unlink: `remove_from_set_and_recycle_if_empty`. -- Avoid API shapes that remove entries without recycling. - -2. Warm up before judging allocation behavior. - -- First request/phase discovers sizes and pays most miss costs. -- Evaluate steady-state from later requests, not request 1. - -3. Track pool misses and pool resizes separately. - -- `pool_set_miss_create` answers "fresh inner-set allocation". -- `pool_set_resize` answers "pool metadata growth pressure". -- Both are needed; misses alone are not the whole picture. - -4. Keep attribution in the same log stream. - -- Use request markers (`ALLOC_REQ_BEGIN/SUMMARY/END`) in alloc log. -- Include startup phase markers. -- This is required to connect events to concrete commits/requests. - -5. Set initial capacity from expected concurrent recycled keys. - -- Too small: more `pool_set_resize` and potential pressure. -- Too large: higher resident memory. -- Current implementation grows on demand; initial capacity still affects early behavior. - -6. Use `tighten` deliberately, not continuously. - -- `tighten` is allocating by design. -- Reserve it for explicit maintenance points after major churn phases. - -## Test guidance (important) - -For this structure, "no allocation" should be specified precisely: - -- If requirement is "no fresh set allocation after warmup under churn", - assert `debug_miss_count` delta is `0` in measured phase. -- Do not equate this with `words/iter = 0` in generic churn loops: - other structures (outer map/set internals, diagnostics, etc.) may allocate. - -Current churn tests in `AllocTest.ml` use this pattern: - -- warmup first, -- measure churn loop, -- assert `pool_miss_delta = 0`. - -## Reusable lessons for Map-of-Map work - -Use this exact process for `Map>`: - -1. Define churn-safe teardown APIs first (remove+recycle semantics explicit). -2. Add event-level instrumentation for misses/resizes with request attribution. -3. Run realistic replay, not only synthetic microbenchmarks. -4. Separate startup from steady-state in analysis. -5. Convert findings into budgeted assertions in tests (post-warmup deltas). - -This avoids overfitting to synthetic "zero words/iter" and keeps API design aligned with production behavior. diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 57f852b2ec3..51381ec05bd 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -400,7 +400,7 @@ let create ~max_nodes ~max_edges = { current = StableSet.create (); edge_map = StableMap.create (); - pred_map = ReactivePoolMapSet.create ~capacity:128; + pred_map = ReactivePoolMapSet.create (); roots = StableSet.create (); output_wave = ReactiveWave.create ~max_entries:max_nodes (); deleted_nodes = StableSet.create (); @@ -432,6 +432,7 @@ let create ~max_nodes ~max_edges = let destroy t = StableSet.destroy t.current; StableMap.destroy t.edge_map; + ReactivePoolMapSet.destroy t.pred_map; StableSet.destroy t.roots; StableSet.destroy t.deleted_nodes; StableSet.destroy t.rederive_pending; @@ -474,9 +475,9 @@ let remove_pred t ~target ~pred = let has_live_pred_key t pred = StableSet.mem t.current (stable_key pred) let has_live_predecessor t k = - let r = ReactivePoolMapSet.find_maybe t.pred_map k in + let r = ReactivePoolMapSet.find_inner_maybe t.pred_map k in if Maybe.is_some r then - ReactiveHash.Set.exists_with has_live_pred_key t (Maybe.unsafe_get r) + StableSet.exists_with (Obj.magic has_live_pred_key) t (Maybe.unsafe_get r) else false let add_pred_for_src (t, src) target = add_pred t ~target ~pred:src diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index f8388db9955..9a5cd88fd75 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -50,8 +50,8 @@ let create ~f ~merge = { f; merge; - provenance = ReactivePoolMapSet.create ~capacity:128; - contributions = ReactivePoolMapMap.create ~capacity:128; + provenance = ReactivePoolMapSet.create (); + contributions = ReactivePoolMapMap.create (); target = StableMap.create (); scratch = StableMap.create (); affected = StableSet.create (); @@ -74,6 +74,8 @@ let create ~f ~merge = t let destroy t = + ReactivePoolMapSet.destroy t.provenance; + ReactivePoolMapMap.destroy t.contributions; StableMap.destroy t.target; StableMap.destroy t.scratch; StableSet.destroy t.affected; diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 860581afbca..fb824fc39f3 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -59,11 +59,11 @@ let create ~key_of ~f ~merge ~right_get = merge; right_get; left_entries = StableMap.create (); - provenance = ReactivePoolMapSet.create ~capacity:128; - contributions = ReactivePoolMapMap.create ~capacity:128; + provenance = ReactivePoolMapSet.create (); + contributions = ReactivePoolMapMap.create (); target = StableMap.create (); left_to_right_key = StableMap.create (); - right_key_to_left_keys = ReactivePoolMapSet.create ~capacity:128; + right_key_to_left_keys = ReactivePoolMapSet.create (); left_scratch = StableMap.create (); right_scratch = StableMap.create (); affected = StableSet.create (); @@ -87,8 +87,11 @@ let create ~key_of ~f ~merge ~right_get = let destroy t = StableMap.destroy t.left_entries; + ReactivePoolMapSet.destroy t.provenance; + ReactivePoolMapMap.destroy t.contributions; StableMap.destroy t.target; StableMap.destroy t.left_to_right_key; + ReactivePoolMapSet.destroy t.right_key_to_left_keys; StableMap.destroy t.left_scratch; StableMap.destroy t.right_scratch; StableSet.destroy t.affected; @@ -194,9 +197,9 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = 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; - let mb = ReactivePoolMapSet.find_maybe t.right_key_to_left_keys k2 in + let mb = ReactivePoolMapSet.find_inner_maybe t.right_key_to_left_keys k2 in if Maybe.is_some mb then - ReactiveHash.Set.iter_with reprocess_left_entry t (Maybe.unsafe_get mb) + StableSet.iter_with (Obj.magic reprocess_left_entry) t (Maybe.unsafe_get mb) let count_output_entry (r : process_result) _k mv = let mv = Stable.unsafe_to_value mv in diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml index 7e4d5c4f20b..564ddea3a7c 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.ml +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -1,101 +1,68 @@ -(** A map from outer keys to inner maps, with pooled recycling of inner maps. +(** A map from outer keys to inner maps, backed by stable storage. - This mirrors the churn-safe API style of [ReactivePoolMapSet] for - map-of-map structures. *) + Each outer key owns its inner map. When an outer binding is removed, the + inner map is destroyed immediately. *) -type ('ko, 'ki, 'v) t = { - outer: ('ko, ('ki, 'v) ReactiveHash.Map.t) ReactiveHash.Map.t; - mutable pool: ('ki, 'v) ReactiveHash.Map.t array; - mutable pool_len: int; - mutable recycle_count: int; - mutable miss_count: int; -} +type ('ko, 'ki, 'v) t = ('ko, ('ki, 'v) StableMap.t) StableMap.t -let create ~capacity:pool_capacity = - { - outer = ReactiveHash.Map.create (); - pool = Array.make pool_capacity (Obj.magic 0); - pool_len = 0; - recycle_count = 0; - miss_count = 0; - } +let create () = StableMap.create () -let grow_pool t = - let old_pool = t.pool in - let old_cap = Array.length old_pool in - let new_cap = max 1 (2 * old_cap) in - let new_pool = Array.make new_cap (Obj.magic 0) in - Array.blit old_pool 0 new_pool 0 old_cap; - t.pool <- new_pool; - ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_map_resize - -let pool_push t inner = - if t.pool_len >= Array.length t.pool then grow_pool t; - Array.unsafe_set t.pool t.pool_len inner; - t.pool_len <- t.pool_len + 1 - -let pool_pop t = - if t.pool_len > 0 then ( - t.pool_len <- t.pool_len - 1; - let inner = Array.unsafe_get t.pool t.pool_len in - Array.unsafe_set t.pool t.pool_len (Obj.magic 0); - inner) - else ( - t.miss_count <- t.miss_count + 1; - ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_map_miss_create; - ReactiveHash.Map.create ()) +let destroy t = + StableMap.iter_with + (fun () _ko inner -> StableMap.destroy (Stable.unsafe_to_value inner)) + () t; + StableMap.destroy t let ensure_inner t ko = - let m = ReactiveHash.Map.find_maybe t.outer ko in - if Maybe.is_some m then Maybe.unsafe_get m + let m = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + if Maybe.is_some m then Stable.unsafe_to_value (Maybe.unsafe_get m) else - let inner = pool_pop t in - ReactiveHash.Map.replace t.outer ko inner; + let inner = StableMap.create () in + StableMap.replace t + (Stable.unsafe_of_value ko) + (Stable.unsafe_of_value inner); inner let replace t ko ki v = let inner = ensure_inner t ko in - ReactiveHash.Map.replace inner ki v + StableMap.replace inner + (Stable.unsafe_of_value ki) + (Stable.unsafe_of_value v) let remove_from_inner_and_recycle_if_empty t ko ki = - let mb = ReactiveHash.Map.find_maybe t.outer ko in + let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in if Maybe.is_some mb then ( - let inner = Maybe.unsafe_get mb in - ReactiveHash.Map.remove inner ki; - let after = ReactiveHash.Map.cardinal inner in - if after = 0 then ( - ReactiveHash.Map.remove t.outer ko; - ReactiveHash.Map.clear inner; - pool_push t inner; - t.recycle_count <- t.recycle_count + 1); - ReactiveAllocTrace.emit_op_kind - ReactiveAllocTrace.Pool_map_remove_recycle_if_empty) + let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableMap.remove inner (Stable.unsafe_of_value ki); + if StableMap.cardinal inner = 0 then ( + StableMap.remove t (Stable.unsafe_of_value ko); + StableMap.destroy inner)) let drain_outer t ko ctx f = - let mb = ReactiveHash.Map.find_maybe t.outer ko in + let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in if Maybe.is_some mb then ( - let inner = Maybe.unsafe_get mb in - ReactiveHash.Map.iter_with f ctx inner; - ReactiveHash.Map.remove t.outer ko; - ReactiveHash.Map.clear inner; - pool_push t inner; - t.recycle_count <- t.recycle_count + 1; - ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_map_drain_outer) + let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableMap.iter_with (Obj.magic f) ctx inner; + StableMap.remove t (Stable.unsafe_of_value ko); + StableMap.destroy inner) -let find_inner_maybe t ko = ReactiveHash.Map.find_maybe t.outer ko +let find_inner_maybe t ko = + let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + if Maybe.is_some mb then + Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) + else Maybe.none let iter_inner_with t ko ctx f = - let mb = ReactiveHash.Map.find_maybe t.outer ko in + let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in if Maybe.is_some mb then - ReactiveHash.Map.iter_with f ctx (Maybe.unsafe_get mb) + let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableMap.iter_with (Obj.magic f) ctx inner let inner_cardinal t ko = - let mb = ReactiveHash.Map.find_maybe t.outer ko in - if Maybe.is_some mb then ReactiveHash.Map.cardinal (Maybe.unsafe_get mb) + let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + if Maybe.is_some mb then + StableMap.cardinal (Stable.unsafe_to_value (Maybe.unsafe_get mb)) else 0 -let outer_cardinal t = ReactiveHash.Map.cardinal t.outer - -let tighten t = ReactiveHash.Map.tighten t.outer - -let debug_miss_count t = t.miss_count +let outer_cardinal t = StableMap.cardinal t +let debug_miss_count _t = 0 diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/ReactivePoolMapMap.mli index 40394943bd5..32f001c96b0 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.mli +++ b/analysis/reactive/src/ReactivePoolMapMap.mli @@ -1,13 +1,12 @@ -(** A map from outer keys to inner maps, with pooled recycling of inner maps. - - Designed for churn-heavy map-of-map usage where empty inner maps should be - removed and recycled deterministically. *) +(** A map from outer keys to inner maps, backed by stable storage. *) type ('ko, 'ki, 'v) t -val create : capacity:int -> ('ko, 'ki, 'v) t -(** [create ~capacity] creates an empty pooled map-of-map. - [capacity] is the initial pool capacity; pool grows on demand. *) +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 -> 'ki -> 'v -> unit (** [replace t ko ki v] ensures an inner map for [ko], then sets [ki -> v]. *) @@ -15,17 +14,21 @@ val replace : ('ko, 'ki, 'v) t -> 'ko -> 'ki -> 'v -> unit val remove_from_inner_and_recycle_if_empty : ('ko, 'ki, 'v) t -> 'ko -> 'ki -> unit (** Removes [ki] from [ko]'s inner map. If it becomes empty, removes [ko], - clears and recycles the inner map. No-op if [ko] is absent. *) + and destroys the inner map. No-op if [ko] is absent. *) val drain_outer : ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit (** [drain_outer t ko ctx f] iterates [f ctx ki v] for all entries in [ko]'s - inner map, then removes [ko], clears and recycles the inner map. + 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 -> ('ki, 'v) ReactiveHash.Map.t Maybe.t -(** Zero-allocation lookup of inner map by outer key. *) + ('ko, 'ki, 'v) t -> 'ko -> ('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 -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit @@ -35,8 +38,6 @@ val iter_inner_with : val inner_cardinal : ('ko, 'ki, 'v) t -> 'ko -> int val outer_cardinal : ('ko, 'ki, 'v) t -> int -val tighten : ('ko, 'ki, 'v) t -> unit -(** Shrinks the outer map capacity after major churn. *) - val debug_miss_count : ('ko, 'ki, 'v) t -> int -(** Number of pool misses (fresh inner-map allocations) since creation. *) +(** Always [0] in the stable-backed implementation. Kept for diagnostics and + allocation-test compatibility. *) diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml index 4f868828544..0e20634341b 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.ml +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -1,107 +1,62 @@ -(** A map from keys to sets, with an internal pool for recycling inner sets. +(** A map from keys to sets, backed by stable storage. - When a key is removed via [drain_key] or - [remove_from_set_and_recycle_if_empty], its inner set is cleared and returned - to a pool. When a new key is added via [add], a set is taken from the - pool (if available) instead of allocating a fresh one. + Each outer key owns its inner set. When an outer binding is removed, the + inner set is destroyed immediately. *) - This eliminates allocation under key churn (e.g., position keys that shift - on every source edit). *) +type ('k, 'v) t = ('k, 'v StableSet.t) StableMap.t -type ('k, 'v) t = { - outer: ('k, 'v ReactiveHash.Set.t) ReactiveHash.Map.t; - mutable pool: 'v ReactiveHash.Set.t array; - mutable pool_len: int; - mutable recycle_count: int; - mutable miss_count: int; -} +let create () = StableMap.create () -let create ~capacity:pool_capacity = - { - outer = ReactiveHash.Map.create (); - pool = Array.make pool_capacity (Obj.magic 0); - pool_len = 0; - recycle_count = 0; - miss_count = 0; - } - -let grow_pool t = - let old_pool = t.pool in - let old_cap = Array.length old_pool in - let new_cap = max 1 (2 * old_cap) in - let new_pool = Array.make new_cap (Obj.magic 0) in - Array.blit old_pool 0 new_pool 0 old_cap; - t.pool <- new_pool; - ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_set_resize - -let pool_push t set = - if t.pool_len >= Array.length t.pool then grow_pool t; - Array.unsafe_set t.pool t.pool_len set; - t.pool_len <- t.pool_len + 1 - -let pool_pop t = - if t.pool_len > 0 then ( - t.pool_len <- t.pool_len - 1; - let set = Array.unsafe_get t.pool t.pool_len in - Array.unsafe_set t.pool t.pool_len (Obj.magic 0); - set) - else ( - t.miss_count <- t.miss_count + 1; - ReactiveAllocTrace.emit_alloc_kind ReactiveAllocTrace.Pool_set_miss_create; - ReactiveHash.Set.create ()) +let destroy t = + StableMap.iter_with + (fun () _k set -> StableSet.destroy (Stable.unsafe_to_value set)) + () t; + StableMap.destroy t let ensure t k = - let m = ReactiveHash.Map.find_maybe t.outer k in - if Maybe.is_some m then Maybe.unsafe_get m + let m = StableMap.find_maybe t (Stable.unsafe_of_value k) in + if Maybe.is_some m then Stable.unsafe_to_value (Maybe.unsafe_get m) else - let set = pool_pop t in - ReactiveHash.Map.replace t.outer k set; + let set = StableSet.create () in + StableMap.replace t + (Stable.unsafe_of_value k) + (Stable.unsafe_of_value set); set let add t k v = let set = ensure t k in - ReactiveHash.Set.add set v + StableSet.add set (Stable.unsafe_of_value v) let drain_key t k ctx f = - let mb = ReactiveHash.Map.find_maybe t.outer k in + let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in if Maybe.is_some mb then ( - let set = Maybe.unsafe_get mb in - ReactiveHash.Set.iter_with f ctx set; - ReactiveHash.Map.remove t.outer k; - ReactiveHash.Set.clear set; - pool_push t set; - t.recycle_count <- t.recycle_count + 1; - ReactiveAllocTrace.emit_op_kind ReactiveAllocTrace.Pool_set_drain_key) + let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableSet.iter_with (Obj.magic f) ctx set; + StableMap.remove t (Stable.unsafe_of_value k); + StableSet.destroy set) let remove_from_set_and_recycle_if_empty t k v = - let mb = ReactiveHash.Map.find_maybe t.outer k in + let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in if Maybe.is_some mb then ( - let set = Maybe.unsafe_get mb in - ReactiveHash.Set.remove set v; - let after = ReactiveHash.Set.cardinal set in - if after = 0 then ( - ReactiveHash.Map.remove t.outer k; - ReactiveHash.Set.clear set; - pool_push t set; - t.recycle_count <- t.recycle_count + 1); - ReactiveAllocTrace.emit_op_kind - ReactiveAllocTrace.Pool_set_remove_recycle_if_empty) - -let find_maybe t k = ReactiveHash.Map.find_maybe t.outer k + let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableSet.remove set (Stable.unsafe_of_value v); + if StableSet.cardinal set = 0 then ( + StableMap.remove t (Stable.unsafe_of_value k); + StableSet.destroy set)) -let iter_with t ctx f = ReactiveHash.Map.iter_with f ctx t.outer +let find_inner_maybe t k = + let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + if Maybe.is_some mb then + Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) + else Maybe.none -let recycle_inner_set t _k set = - ReactiveHash.Set.clear set; - pool_push t set; - t.recycle_count <- t.recycle_count + 1 +let iter_with t ctx f = + StableMap.iter_with (Obj.magic f) ctx t let clear t = - ReactiveHash.Map.iter_with recycle_inner_set t t.outer; - ReactiveHash.Map.clear t.outer - -let tighten t = ReactiveHash.Map.tighten t.outer - -let cardinal t = ReactiveHash.Map.cardinal t.outer - -let debug_miss_count t = t.miss_count + StableMap.iter_with + (fun () _k set -> StableSet.destroy (Stable.unsafe_to_value set)) + () t; + StableMap.clear t +let cardinal t = StableMap.cardinal t +let debug_miss_count _t = 0 diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli index 656358a104b..5d7182e22ab 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.mli +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -1,42 +1,43 @@ -(** A map from keys to sets, with an internal pool for recycling inner sets. - - Eliminates allocation under key churn by recycling cleared inner sets. *) +(** A map from keys to sets, backed by stable storage. *) type ('k, 'v) t -val create : capacity:int -> ('k, 'v) t -(** [create ~capacity] creates an empty pool map set. - [capacity] is the initial pool capacity; the pool grows on demand. *) +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 -> 'v -> unit (** [add t k v] ensures a set exists for [k] and adds [v] to it. *) val drain_key : ('k, 'v) t -> 'k -> 'a -> ('a -> 'v -> 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 recycles its inner set. + 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 -> 'v -> unit (** [remove_from_set_and_recycle_if_empty t k v] removes [v] from [k]'s set. - If the set becomes empty, [k] is recycled. No-op if [k] is absent. *) + If the set becomes empty, [k] is removed and its inner set destroyed. + No-op if [k] is absent. *) -val find_maybe : ('k, 'v) t -> 'k -> 'v ReactiveHash.Set.t Maybe.t -(** Zero-allocation lookup. *) +val find_inner_maybe : ('k, 'v) t -> 'k -> 'v StableSet.t Maybe.t +(** Zero-allocation lookup. + + 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. *) val iter_with : - ('k, 'v) t -> 'a -> ('a -> 'k -> 'v ReactiveHash.Set.t -> unit) -> unit + ('k, 'v) t -> 'a -> ('a -> 'k -> '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; inner sets are cleared and recycled. *) - -val tighten : ('k, 'v) t -> unit -(** [tighten t] shrinks the outer map's capacity after key churn. - Call explicitly after a batch of key removals. *) +(** 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 -(** Number of pool misses (fresh set allocations) since creation. - Intended for diagnostics and allocation tests. *) +(** Always [0] in the stable-backed implementation. Kept for diagnostics and + allocation-test compatibility. *) From 4586461eb403abfb0ed934de9794e5503e1d8c88 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 15:14:03 +0100 Subject: [PATCH 34/54] stable map and stable set --- analysis/reactive/src/StableMap.ml | 101 ++++++++------- analysis/reactive/src/StableSet.ml | 13 ++ analysis/reactive/src/StableSet.mli | 3 + analysis/reactive/test/AllocTest.ml | 187 +--------------------------- 4 files changed, 70 insertions(+), 234 deletions(-) diff --git a/analysis/reactive/src/StableMap.ml b/analysis/reactive/src/StableMap.ml index f2e5e44eb59..ee7aaaa7298 100644 --- a/analysis/reactive/src/StableMap.ml +++ b/analysis/reactive/src/StableMap.ml @@ -1,7 +1,4 @@ -type ('k, 'v) t = { - keys: ('k, int, int) Allocator.Block2.t; - vals: 'v Allocator.Block.t; -} +type ('k, 'v) t = (Obj.t, int, int) Allocator.Block2.t let initial_capacity = 8 let max_load_percent = 82 @@ -12,33 +9,45 @@ 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 key_capacity t = Allocator.Block2.capacity t.keys -let population t = Allocator.Block2.get0 t.keys -let set_population t n = Allocator.Block2.set0 t.keys n -let occupation t = Allocator.Block2.get1 t.keys -let set_occupation t n = Allocator.Block2.set1 t.keys n -let[@inline] mask t = key_capacity t - 1 +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] start t x = Hashtbl.hash (Stable.unsafe_to_value x) land mask t +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.unsafe_to_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 key_capacity t - 1 do - Allocator.Block2.set t.keys i (empty_slot ()) + for i = 0 to pair_capacity t - 1 do + set_key t i (empty_slot ()) done let create () = - let keys = Allocator.Block2.create ~capacity:initial_capacity ~x0:0 ~y0:0 in - let vals = Allocator.Block.create ~capacity:initial_capacity in - let t = {keys; vals} in + let t = + Allocator.Block2.create ~capacity:(2 * initial_capacity) ~x0:0 ~y0:0 + in clear_keys t; t -let destroy t = - Allocator.Block2.destroy t.keys; - Allocator.Block.destroy t.vals +let destroy = Allocator.Block2.destroy let clear t = set_population t 0; @@ -48,37 +57,33 @@ let clear t = let insert_absent t k v = let empty : 'k Stable.t = empty_slot () in let j = ref (start t k) in - while Allocator.Block2.get t.keys !j != empty do + while get_key t !j != empty do j := next t !j done; - Allocator.Block2.set t.keys !j k; - Allocator.Block.set t.vals !j v + set_key t !j k; + set_val t !j v let resize t new_cap = - let old_cap = key_capacity t in - let old_keys = Allocator.Block2.create ~capacity:old_cap ~x0:0 ~y0:0 in - let old_vals = Allocator.Block.create ~capacity:old_cap in - Allocator.Block2.blit ~src:t.keys ~src_pos:0 ~dst:old_keys ~dst_pos:0 - ~len:old_cap; - Allocator.Block.blit ~src:t.vals ~src_pos:0 ~dst:old_vals ~dst_pos:0 - ~len:old_cap; - Allocator.Block2.resize t.keys ~capacity:new_cap; - Allocator.Block.resize t.vals ~capacity: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 = Allocator.Block2.get old_keys i in + let k = get_key old i in if k != empty_slot () && k != tomb_slot () then ( - insert_absent t k (Allocator.Block.get old_vals i); + 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_keys; - Allocator.Block.destroy old_vals + Allocator.Block2.destroy old let maybe_grow_before_insert t = - let cap = key_capacity t in + 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) @@ -90,19 +95,19 @@ let replace t k v = let first_tomb = ref (-1) in let done_ = ref false in while not !done_ do - let current = Allocator.Block2.get t.keys !j in + 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); - Allocator.Block2.set t.keys dst k; - Allocator.Block.set t.vals dst v; + 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 ( - Allocator.Block.set t.vals !j v; + set_val t !j v; done_ := true) else j := next t !j done @@ -113,11 +118,11 @@ let remove t k = let j = ref (start t k) in let done_ = ref false in while not !done_ do - let current = Allocator.Block2.get t.keys !j in + 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 ( - Allocator.Block2.set t.keys !j tomb; + set_key t !j tomb; set_population t (population t - 1); done_ := true) else j := next t !j @@ -130,7 +135,7 @@ let mem t k = let found = ref false in let done_ = ref false in while not !done_ do - let current = Allocator.Block2.get t.keys !j in + 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 ( @@ -147,11 +152,11 @@ let find_maybe t k = let found = ref Maybe.none in let done_ = ref false in while not !done_ do - let current = Allocator.Block2.get t.keys !j in + 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 (Allocator.Block.get t.vals !j); + found := Maybe.some (get_val t !j); done_ := true) else j := next t !j done; @@ -161,9 +166,9 @@ 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 key_capacity t - 1 do - let k = Allocator.Block2.get t.keys i in - if k != empty && k != tomb then f arg k (Allocator.Block.get t.vals i) + 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 f t = iter_with (fun f k v -> f k v) f t diff --git a/analysis/reactive/src/StableSet.ml b/analysis/reactive/src/StableSet.ml index 36afcb4e4a8..dfa0bb91cec 100644 --- a/analysis/reactive/src/StableSet.ml +++ b/analysis/reactive/src/StableSet.ml @@ -138,4 +138,17 @@ let iter_with (type a k) (f : a -> k Stable.t -> unit) (arg : a) (t : k t) = if x != empty_sentinel () && x != tomb_sentinel () then f arg 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 cardinal = population diff --git a/analysis/reactive/src/StableSet.mli b/analysis/reactive/src/StableSet.mli index ee2726df09e..08185a13aa3 100644 --- a/analysis/reactive/src/StableSet.mli +++ b/analysis/reactive/src/StableSet.mli @@ -27,5 +27,8 @@ val mem : 'a t -> 'a Stable.t -> bool 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 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 cardinal : 'a t -> int (** Number of elements currently stored. *) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 54f7fbef03e..14c9343f924 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -526,187 +526,6 @@ let test_reactive_flatmap_alloc () = print_stable_usage (); Printf.printf "PASSED\n\n" -(* ---- PoolMapSet allocation ---- *) - -type empty_set_stats = {mutable total: int; mutable empty: int} - -let count_pool_empty_sets pms = - let s = {total = 0; empty = 0} in - ReactivePoolMapSet.iter_with pms s (fun st _k set -> - st.total <- st.total + 1; - if ReactiveHash.Set.cardinal set = 0 then st.empty <- st.empty + 1); - s - -let test_pool_map_set_pattern_drain_key_churn () = - reset_stable_state (); - Printf.printf "=== Test: PoolMapSet pattern (drain_key churn) ===\n"; - let n = 100 in - let iters = 100 in - let pms = ReactivePoolMapSet.create ~capacity:(n * 2) in - - for i = 0 to n - 1 do - ReactivePoolMapSet.add pms i i - done; - - let miss_before = ReactivePoolMapSet.debug_miss_count pms in - ignore (words_since ()); - for iter = 1 to iters do - let base = iter * n in - for i = 0 to n - 1 do - ReactivePoolMapSet.drain_key pms (base - n + i) () (fun () _ -> ()) - done; - for i = 0 to n - 1 do - ReactivePoolMapSet.add pms (base + i) i - done - done; - let words = words_since () / iters in - let miss_after = ReactivePoolMapSet.debug_miss_count pms in - let miss_delta = miss_after - miss_before in - let st = count_pool_empty_sets pms in - Printf.printf - " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_sets=%d/%d\n" words - miss_delta - (ReactivePoolMapSet.cardinal pms) - st.empty st.total; - assert (ReactivePoolMapSet.cardinal pms = n); - assert (st.empty = 0); - assert (miss_delta = 0); - print_stable_usage (); - Printf.printf "PASSED\n\n" - -let test_pool_map_set_pattern_remove_recycle_churn () = - reset_stable_state (); - Printf.printf - "=== Test: PoolMapSet pattern (remove_from_set_and_recycle_if_empty churn) \ - ===\n"; - let n = 100 in - let iters = 100 in - let pms = ReactivePoolMapSet.create ~capacity:(n * 2) in - - for i = 0 to n - 1 do - ReactivePoolMapSet.add pms i i - done; - - let miss_before = ReactivePoolMapSet.debug_miss_count pms in - ignore (words_since ()); - for iter = 1 to iters do - let base = iter * n in - for i = 0 to n - 1 do - ReactivePoolMapSet.remove_from_set_and_recycle_if_empty pms - (base - n + i) - i - done; - for i = 0 to n - 1 do - ReactivePoolMapSet.add pms (base + i) i - done - done; - let words = words_since () / iters in - let miss_after = ReactivePoolMapSet.debug_miss_count pms in - let miss_delta = miss_after - miss_before in - let st = count_pool_empty_sets pms in - Printf.printf - " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_sets=%d/%d\n" words - miss_delta - (ReactivePoolMapSet.cardinal pms) - st.empty st.total; - assert (ReactivePoolMapSet.cardinal pms = n); - assert (st.empty = 0); - assert (miss_delta = 0); - print_stable_usage (); - Printf.printf "PASSED\n\n" - -(* ---- PoolMapMap allocation ---- *) - -type inner_map_stats = {mutable empty: int} - -let count_empty_inner_maps pmm ~start ~count = - let s = {empty = 0} in - for i = 0 to count - 1 do - if ReactivePoolMapMap.inner_cardinal pmm (start + i) = 0 then - s.empty <- s.empty + 1 - done; - s - -let test_pool_map_map_pattern_drain_outer_churn () = - reset_stable_state (); - Printf.printf "=== Test: PoolMapMap pattern (drain_outer churn) ===\n"; - let n = 100 in - let iters = 100 in - let pmm = ReactivePoolMapMap.create ~capacity:(n * 2) in - - for i = 0 to n - 1 do - ReactivePoolMapMap.replace pmm i i i - done; - - let miss_before = ReactivePoolMapMap.debug_miss_count pmm in - ignore (words_since ()); - for iter = 1 to iters do - let base = iter * n in - for i = 0 to n - 1 do - ReactivePoolMapMap.drain_outer pmm (base - n + i) () (fun () _ _ -> ()) - done; - for i = 0 to n - 1 do - ReactivePoolMapMap.replace pmm (base + i) i i - done - done; - let words = words_since () / iters in - let miss_after = ReactivePoolMapMap.debug_miss_count pmm in - let miss_delta = miss_after - miss_before in - let final_start = iters * n in - let st = count_empty_inner_maps pmm ~start:final_start ~count:n in - Printf.printf - " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_inners=%d/%d\n" words - miss_delta - (ReactivePoolMapMap.outer_cardinal pmm) - st.empty n; - assert (ReactivePoolMapMap.outer_cardinal pmm = n); - assert (st.empty = 0); - assert (miss_delta = 0); - print_stable_usage (); - Printf.printf "PASSED\n\n" - -let test_pool_map_map_pattern_remove_recycle_churn () = - reset_stable_state (); - Printf.printf - "=== Test: PoolMapMap pattern (remove_from_inner_and_recycle_if_empty \ - churn) ===\n"; - let n = 100 in - let iters = 100 in - let pmm = ReactivePoolMapMap.create ~capacity:(n * 2) in - - for i = 0 to n - 1 do - ReactivePoolMapMap.replace pmm i i i - done; - - let miss_before = ReactivePoolMapMap.debug_miss_count pmm in - ignore (words_since ()); - for iter = 1 to iters do - let base = iter * n in - for i = 0 to n - 1 do - ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty pmm - (base - n + i) - i - done; - for i = 0 to n - 1 do - ReactivePoolMapMap.replace pmm (base + i) i i - done - done; - let words = words_since () / iters in - let miss_after = ReactivePoolMapMap.debug_miss_count pmm in - let miss_delta = miss_after - miss_before in - let final_start = iters * n in - let st = count_empty_inner_maps pmm ~start:final_start ~count:n in - Printf.printf - " words/iter=%d, pool_miss_delta=%d, outer=%d, empty_inners=%d/%d\n" words - miss_delta - (ReactivePoolMapMap.outer_cardinal pmm) - st.empty n; - assert (ReactivePoolMapMap.outer_cardinal pmm = n); - assert (st.empty = 0); - assert (miss_delta = 0); - print_stable_usage (); - Printf.printf "PASSED\n\n" - let run_all () = Printf.printf "\n====== Allocation Tests ======\n\n"; test_union_alloc (); @@ -716,8 +535,4 @@ let run_all () = test_reactive_union_alloc (); test_reactive_flatmap_alloc (); test_reactive_join_alloc (); - test_reactive_fixpoint_alloc (); - test_pool_map_set_pattern_drain_key_churn (); - test_pool_map_set_pattern_remove_recycle_churn (); - test_pool_map_map_pattern_drain_outer_churn (); - test_pool_map_map_pattern_remove_recycle_churn () + test_reactive_fixpoint_alloc () From 0811e67983db7d9e9eb44d5a62a4747f5d8302d3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 15:18:26 +0100 Subject: [PATCH 35/54] analysis/reactive: hide pool-map inner handles in clients --- analysis/reactive/src/ReactiveFixpoint.ml | 5 +---- analysis/reactive/src/ReactiveJoin.ml | 5 ++--- analysis/reactive/src/ReactivePoolMapSet.ml | 20 +++++++++++++++++--- analysis/reactive/src/ReactivePoolMapSet.mli | 15 +++++++++++++-- 4 files changed, 33 insertions(+), 12 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 51381ec05bd..311e34601f9 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -475,10 +475,7 @@ let remove_pred t ~target ~pred = let has_live_pred_key t pred = StableSet.mem t.current (stable_key pred) let has_live_predecessor t k = - let r = ReactivePoolMapSet.find_inner_maybe t.pred_map k in - if Maybe.is_some r then - StableSet.exists_with (Obj.magic has_live_pred_key) t (Maybe.unsafe_get r) - else false + ReactivePoolMapSet.exists_inner_with t.pred_map k t has_live_pred_key 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 diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index fb824fc39f3..ff49030feec 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -197,9 +197,8 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = 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; - let mb = ReactivePoolMapSet.find_inner_maybe t.right_key_to_left_keys k2 in - if Maybe.is_some mb then - StableSet.iter_with (Obj.magic reprocess_left_entry) t (Maybe.unsafe_get mb) + ReactivePoolMapSet.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 = Stable.unsafe_to_value mv in diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml index 0e20634341b..213db861c5e 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.ml +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -13,6 +13,9 @@ let destroy t = () t; StableMap.destroy t +let destroy_inner_set () _k set = + StableSet.destroy (Stable.unsafe_to_value set) + let ensure t k = let m = StableMap.find_maybe t (Stable.unsafe_of_value k) in if Maybe.is_some m then Stable.unsafe_to_value (Maybe.unsafe_get m) @@ -50,13 +53,24 @@ let find_inner_maybe t k = Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) else Maybe.none +let iter_inner_with t k ctx f = + let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + if Maybe.is_some mb then + let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableSet.iter_with (Obj.magic f) ctx set + +let exists_inner_with t k ctx f = + let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + if Maybe.is_some mb then + let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + StableSet.exists_with (Obj.magic f) ctx set + else false + let iter_with t ctx f = StableMap.iter_with (Obj.magic f) ctx t let clear t = - StableMap.iter_with - (fun () _k set -> StableSet.destroy (Stable.unsafe_to_value set)) - () 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/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli index 5d7182e22ab..c4a4abf3080 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.mli +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -22,11 +22,22 @@ val remove_from_set_and_recycle_if_empty : ('k, 'v) t -> 'k -> 'v -> unit No-op if [k] is absent. *) val find_inner_maybe : ('k, 'v) t -> 'k -> 'v StableSet.t Maybe.t -(** Zero-allocation lookup. +(** 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. *) + [destroy]ed. Prefer {!iter_inner_with} and {!exists_inner_with} when direct + access is not needed. *) + +val iter_inner_with : + ('k, 'v) t -> 'k -> 'a -> ('a -> 'v -> 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 -> 'a -> ('a -> 'v -> 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 -> 'v StableSet.t -> unit) -> unit From 05f2882bc095b705fdeb77c4f20decedf2e93b94 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 16:41:38 +0100 Subject: [PATCH 36/54] analysis/reactive: make pool-map APIs stable-typed --- analysis/reactive/src/ReactiveFixpoint.ml | 11 ++-- analysis/reactive/src/ReactiveFlatMap.ml | 38 +++++++++---- analysis/reactive/src/ReactiveJoin.ml | 56 ++++++++++++++------ analysis/reactive/src/ReactivePoolMapMap.ml | 30 +++++------ analysis/reactive/src/ReactivePoolMapMap.mli | 21 +++++--- analysis/reactive/src/ReactivePoolMapSet.ml | 38 ++++++------- analysis/reactive/src/ReactivePoolMapSet.mli | 16 +++--- 7 files changed, 132 insertions(+), 78 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 311e34601f9..d66179c80e1 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -467,15 +467,18 @@ 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 = ReactivePoolMapSet.add t.pred_map target pred +let add_pred t ~target ~pred = + ReactivePoolMapSet.add t.pred_map (stable_key target) (stable_key pred) let remove_pred t ~target ~pred = - ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred + ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map + (stable_key target) (stable_key pred) -let has_live_pred_key t pred = StableSet.mem t.current (stable_key pred) +let has_live_pred_key t pred = StableSet.mem t.current pred let has_live_predecessor t k = - ReactivePoolMapSet.exists_inner_with t.pred_map k t has_live_pred_key + ReactivePoolMapSet.exists_inner_with t.pred_map (stable_key k) t + has_live_pred_key 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 diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 9a5cd88fd75..4b3a16f6b01 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -33,14 +33,24 @@ and process_result = { (* Emit callback for steady-state — marks affected *) let add_single_contribution (t : (_, _, _, _) t) k2 v2 = - ReactivePoolMapSet.add t.provenance t.current_k1 k2; - ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; + ReactivePoolMapSet.add t.provenance + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value k2); + ReactivePoolMapMap.replace t.contributions + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value v2); StableSet.add t.affected (Stable.unsafe_of_value k2) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = - ReactivePoolMapSet.add t.provenance t.current_k1 k2; - ReactivePoolMapMap.replace t.contributions k2 t.current_k1 v2; + ReactivePoolMapSet.add t.provenance + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value k2); + ReactivePoolMapMap.replace t.contributions + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value v2); StableMap.replace t.target (Stable.unsafe_of_value k2) (Stable.unsafe_of_value v2) @@ -88,15 +98,18 @@ 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 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 - t.current_k1; - StableSet.add t.affected (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value t.current_k1); + StableSet.add t.affected k2 let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; - ReactivePoolMapSet.drain_key t.provenance k1 t remove_one_contribution + ReactivePoolMapSet.drain_key t.provenance + (Stable.unsafe_of_value k1) + t remove_one_contribution (* Merge callback for recompute_target iter_with *) let merge_one_contribution (t : (_, _, _, _) t) _k1 v = + let v = Stable.unsafe_to_value v in if t.merge_first then ( t.merge_acc <- v; t.merge_first <- false) @@ -104,10 +117,15 @@ let merge_one_contribution (t : (_, _, _, _) t) _k1 v = let recompute_target (t : (_, _, _, _) t) k2 = let k2 = Stable.unsafe_to_value k2 in - if ReactivePoolMapMap.inner_cardinal t.contributions k2 > 0 then ( + if + ReactivePoolMapMap.inner_cardinal t.contributions + (Stable.unsafe_of_value k2) + > 0 + then ( t.merge_first <- true; - ReactivePoolMapMap.iter_inner_with t.contributions k2 t - merge_one_contribution; + ReactivePoolMapMap.iter_inner_with t.contributions + (Stable.unsafe_of_value k2) + t merge_one_contribution; StableMap.replace t.target (Stable.unsafe_of_value k2) (Stable.unsafe_of_value t.merge_acc); diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index ff49030feec..6f9795a48c6 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -39,14 +39,24 @@ and process_result = { (* Emit callback for steady-state — marks affected *) let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = - ReactivePoolMapSet.add t.provenance t.current_k1 k3; - ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; + ReactivePoolMapSet.add t.provenance + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value k3); + ReactivePoolMapMap.replace t.contributions + (Stable.unsafe_of_value k3) + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value v3); StableSet.add t.affected (Stable.unsafe_of_value k3) (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = - ReactivePoolMapSet.add t.provenance t.current_k1 k3; - ReactivePoolMapMap.replace t.contributions k3 t.current_k1 v3; + ReactivePoolMapSet.add t.provenance + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value k3); + ReactivePoolMapMap.replace t.contributions + (Stable.unsafe_of_value k3) + (Stable.unsafe_of_value t.current_k1) + (Stable.unsafe_of_value v3); StableMap.replace t.target (Stable.unsafe_of_value k3) (Stable.unsafe_of_value v3) @@ -106,12 +116,14 @@ 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 = ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 - t.current_k1; - StableSet.add t.affected (Stable.unsafe_of_value k3) + (Stable.unsafe_of_value t.current_k1); + StableSet.add t.affected k3 let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; - ReactivePoolMapSet.drain_key t.provenance k1 t remove_one_contribution_key + ReactivePoolMapSet.drain_key t.provenance + (Stable.unsafe_of_value k1) + t remove_one_contribution_key let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = let mb = @@ -121,7 +133,9 @@ let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = let old_k2 = Stable.unsafe_to_value (Maybe.unsafe_get mb) in StableMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); ReactivePoolMapSet.remove_from_set_and_recycle_if_empty - t.right_key_to_left_keys old_k2 k1) + t.right_key_to_left_keys + (Stable.unsafe_of_value old_k2) + (Stable.unsafe_of_value k1)) let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = remove_left_contributions t k1; @@ -130,7 +144,9 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = StableMap.replace t.left_to_right_key (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); - ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; + ReactivePoolMapSet.add t.right_key_to_left_keys + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value k1); let right_val = Stable.unsafe_to_value (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) @@ -145,6 +161,7 @@ let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = (* Merge callback for recompute_target iter_with *) let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = + let v = Stable.unsafe_to_value v in if t.merge_first then ( t.merge_acc <- v; t.merge_first <- false) @@ -152,10 +169,15 @@ let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = let recompute_target (t : (_, _, _, _, _, _) t) k3 = let k3 = Stable.unsafe_to_value k3 in - if ReactivePoolMapMap.inner_cardinal t.contributions k3 > 0 then ( + if + ReactivePoolMapMap.inner_cardinal t.contributions + (Stable.unsafe_of_value k3) + > 0 + then ( t.merge_first <- true; - ReactivePoolMapMap.iter_inner_with t.contributions k3 t - merge_one_contribution; + ReactivePoolMapMap.iter_inner_with t.contributions + (Stable.unsafe_of_value k3) + t merge_one_contribution; StableMap.replace t.target (Stable.unsafe_of_value k3) (Stable.unsafe_of_value t.merge_acc); @@ -186,6 +208,7 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = + let k1 = Stable.unsafe_to_value k1 in let mb = StableMap.find_maybe t.left_entries (Stable.unsafe_of_value k1) in if Maybe.is_some mb then process_left_entry t k1 (Stable.unsafe_to_value (Maybe.unsafe_get mb)) @@ -197,8 +220,9 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = 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; - ReactivePoolMapSet.iter_inner_with t.right_key_to_left_keys k2 t - reprocess_left_entry + ReactivePoolMapSet.iter_inner_with t.right_key_to_left_keys + (Stable.unsafe_of_value k2) + t reprocess_left_entry let count_output_entry (r : process_result) _k mv = let mv = Stable.unsafe_to_value mv in @@ -240,7 +264,9 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = StableMap.replace t.left_to_right_key (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); - ReactivePoolMapSet.add t.right_key_to_left_keys k2 k1; + ReactivePoolMapSet.add t.right_key_to_left_keys + (Stable.unsafe_of_value k2) + (Stable.unsafe_of_value k1); let right_val = Stable.unsafe_to_value (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/ReactivePoolMapMap.ml index 564ddea3a7c..568fa553047 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.ml +++ b/analysis/reactive/src/ReactivePoolMapMap.ml @@ -14,52 +14,48 @@ let destroy t = StableMap.destroy t let ensure_inner t ko = - let m = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + let m = StableMap.find_maybe t ko in if Maybe.is_some m then Stable.unsafe_to_value (Maybe.unsafe_get m) else let inner = StableMap.create () in - StableMap.replace t - (Stable.unsafe_of_value ko) - (Stable.unsafe_of_value inner); + 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 - (Stable.unsafe_of_value ki) - (Stable.unsafe_of_value v) + StableMap.replace inner ki v let remove_from_inner_and_recycle_if_empty t ko ki = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then ( let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableMap.remove inner (Stable.unsafe_of_value ki); + StableMap.remove inner ki; if StableMap.cardinal inner = 0 then ( - StableMap.remove t (Stable.unsafe_of_value ko); + StableMap.remove t ko; StableMap.destroy inner)) let drain_outer t ko ctx f = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then ( let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableMap.iter_with (Obj.magic f) ctx inner; - StableMap.remove t (Stable.unsafe_of_value ko); + 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 (Stable.unsafe_of_value ko) in + let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) else Maybe.none let iter_inner_with t ko ctx f = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableMap.iter_with (Obj.magic f) ctx inner + StableMap.iter_with f ctx inner let inner_cardinal t ko = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value ko) in + let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then StableMap.cardinal (Stable.unsafe_to_value (Maybe.unsafe_get mb)) else 0 diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/ReactivePoolMapMap.mli index 32f001c96b0..9e6a9110cff 100644 --- a/analysis/reactive/src/ReactivePoolMapMap.mli +++ b/analysis/reactive/src/ReactivePoolMapMap.mli @@ -8,22 +8,27 @@ val create : unit -> ('ko, 'ki, 'v) t val destroy : ('ko, 'ki, 'v) t -> unit (** Destroy the outer map and all owned inner maps. *) -val replace : ('ko, 'ki, 'v) t -> 'ko -> 'ki -> 'v -> unit +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 -> 'ki -> unit + ('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 -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit + ('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 -> ('ki, 'v) StableMap.t Maybe.t + ('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 @@ -31,11 +36,15 @@ val find_inner_maybe : structure is [destroy]ed. *) val iter_inner_with : - ('ko, 'ki, 'v) t -> 'ko -> 'a -> ('a -> 'ki -> 'v -> unit) -> unit + ('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 -> int +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 diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/ReactivePoolMapSet.ml index 213db861c5e..b320e2a3404 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.ml +++ b/analysis/reactive/src/ReactivePoolMapSet.ml @@ -13,61 +13,61 @@ let destroy t = () t; StableMap.destroy t -let destroy_inner_set () _k set = - StableSet.destroy (Stable.unsafe_to_value set) +let destroy_inner_set () _k set = StableSet.destroy (Stable.unsafe_to_value set) let ensure t k = - let m = StableMap.find_maybe t (Stable.unsafe_of_value k) in + let m = StableMap.find_maybe t k in if Maybe.is_some m then Stable.unsafe_to_value (Maybe.unsafe_get m) else let set = StableSet.create () in - StableMap.replace t - (Stable.unsafe_of_value k) - (Stable.unsafe_of_value set); + StableMap.replace t k (Stable.unsafe_of_value set); set let add t k v = let set = ensure t k in - StableSet.add set (Stable.unsafe_of_value v) + StableSet.add set v let drain_key t k ctx f = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + let mb = StableMap.find_maybe t k in if Maybe.is_some mb then ( let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableSet.iter_with (Obj.magic f) ctx set; - StableMap.remove t (Stable.unsafe_of_value k); + 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 (Stable.unsafe_of_value k) in + let mb = StableMap.find_maybe t k in if Maybe.is_some mb then ( let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableSet.remove set (Stable.unsafe_of_value v); + StableSet.remove set v; if StableSet.cardinal set = 0 then ( - StableMap.remove t (Stable.unsafe_of_value k); + StableMap.remove t k; StableSet.destroy set)) let find_inner_maybe t k = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + let mb = StableMap.find_maybe t k in if Maybe.is_some mb then Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) else Maybe.none let iter_inner_with t k ctx f = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + let mb = StableMap.find_maybe t k in if Maybe.is_some mb then let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableSet.iter_with (Obj.magic f) ctx set + StableSet.iter_with f ctx set let exists_inner_with t k ctx f = - let mb = StableMap.find_maybe t (Stable.unsafe_of_value k) in + let mb = StableMap.find_maybe t k in if Maybe.is_some mb then let set = Stable.unsafe_to_value (Maybe.unsafe_get mb) in - StableSet.exists_with (Obj.magic f) ctx set + StableSet.exists_with f ctx set else false let iter_with t ctx f = - StableMap.iter_with (Obj.magic f) ctx t + StableMap.iter_with + (fun ctx stable_k stable_set -> + f ctx stable_k (Stable.unsafe_to_value stable_set)) + ctx t let clear t = StableMap.iter_with destroy_inner_set () t; diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/ReactivePoolMapSet.mli index c4a4abf3080..647353effdf 100644 --- a/analysis/reactive/src/ReactivePoolMapSet.mli +++ b/analysis/reactive/src/ReactivePoolMapSet.mli @@ -8,20 +8,22 @@ val create : unit -> ('k, 'v) t val destroy : ('k, 'v) t -> unit (** Destroy the outer map and all owned inner sets. *) -val add : ('k, 'v) t -> 'k -> 'v -> unit +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 -> 'a -> ('a -> 'v -> unit) -> unit +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 -> 'v -> unit +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 -> 'v StableSet.t Maybe.t +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 @@ -30,17 +32,17 @@ val find_inner_maybe : ('k, 'v) t -> 'k -> 'v StableSet.t Maybe.t access is not needed. *) val iter_inner_with : - ('k, 'v) t -> 'k -> 'a -> ('a -> 'v -> unit) -> unit + ('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 -> 'a -> ('a -> 'v -> bool) -> bool + ('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 -> 'v StableSet.t -> unit) -> unit + ('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 From fab11828253591e3c59c5ba3afb162229076c972 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 17:53:01 +0100 Subject: [PATCH 37/54] analysis/reactive: rename ReactivePoolMapSet/Map to StableMapSet/Map These modules are now backed by stable storage, so the "Pool" naming no longer reflects their implementation. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 16 +++---- analysis/reactive/src/ReactiveFlatMap.ml | 28 ++++++------- analysis/reactive/src/ReactiveJoin.ml | 42 +++++++++---------- analysis/reactive/src/StableMap.ml | 4 +- ...{ReactivePoolMapMap.ml => StableMapMap.ml} | 0 ...eactivePoolMapMap.mli => StableMapMap.mli} | 0 ...{ReactivePoolMapSet.ml => StableMapSet.ml} | 0 ...eactivePoolMapSet.mli => StableMapSet.mli} | 0 analysis/reactive/src/StableSet.ml | 2 +- 9 files changed, 45 insertions(+), 47 deletions(-) rename analysis/reactive/src/{ReactivePoolMapMap.ml => StableMapMap.ml} (100%) rename analysis/reactive/src/{ReactivePoolMapMap.mli => StableMapMap.mli} (100%) rename analysis/reactive/src/{ReactivePoolMapSet.ml => StableMapSet.ml} (100%) rename analysis/reactive/src/{ReactivePoolMapSet.mli => StableMapSet.mli} (100%) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index d66179c80e1..633100c4c84 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -1,5 +1,5 @@ (* Note on set representations: - [pred_map] is represented by [ReactivePoolMapSet] because its semantics are + [pred_map] is represented by [StableMapSet] because its semantics are exactly map-of-set with churn-safe remove+recycle behavior. *) type 'k metrics_state = { @@ -18,7 +18,7 @@ type 'k metrics_state = { type 'k t = { current: 'k StableSet.t; edge_map: ('k, 'k StableList.inner) StableMap.t; - pred_map: ('k, 'k) ReactivePoolMapSet.t; + pred_map: ('k, 'k) StableMapSet.t; roots: 'k StableSet.t; output_wave: ('k, unit Maybe.t) ReactiveWave.t; (* Scratch tables — allocated once, cleared per apply_list call *) @@ -400,7 +400,7 @@ let create ~max_nodes ~max_edges = { current = StableSet.create (); edge_map = StableMap.create (); - pred_map = ReactivePoolMapSet.create (); + pred_map = StableMapSet.create (); roots = StableSet.create (); output_wave = ReactiveWave.create ~max_entries:max_nodes (); deleted_nodes = StableSet.create (); @@ -432,7 +432,7 @@ let create ~max_nodes ~max_edges = let destroy t = StableSet.destroy t.current; StableMap.destroy t.edge_map; - ReactivePoolMapSet.destroy t.pred_map; + StableMapSet.destroy t.pred_map; StableSet.destroy t.roots; StableSet.destroy t.deleted_nodes; StableSet.destroy t.rederive_pending; @@ -468,16 +468,16 @@ 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 = - ReactivePoolMapSet.add t.pred_map (stable_key target) (stable_key pred) + StableMapSet.add t.pred_map (stable_key target) (stable_key pred) let remove_pred t ~target ~pred = - ReactivePoolMapSet.remove_from_set_and_recycle_if_empty t.pred_map + StableMapSet.remove_from_set_and_recycle_if_empty t.pred_map (stable_key target) (stable_key pred) let has_live_pred_key t pred = StableSet.mem t.current pred let has_live_predecessor t k = - ReactivePoolMapSet.exists_inner_with t.pred_map (stable_key k) t + StableMapSet.exists_inner_with t.pred_map (stable_key k) t has_live_pred_key let add_pred_for_src (t, src) target = add_pred t ~target ~pred:src @@ -523,7 +523,7 @@ let apply_edge_update t ~src ~new_successors = let initialize t ~roots ~edges = StableSet.clear t.roots; StableMap.clear t.edge_map; - ReactivePoolMapSet.clear t.pred_map; + StableMapSet.clear t.pred_map; ReactiveWave.iter roots (fun k _ -> StableSet.add t.roots k); ReactiveWave.iter edges (fun k successors -> apply_edge_update t ~src:(Stable.unsafe_to_value k) diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 4b3a16f6b01..99312f72e1a 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -4,8 +4,8 @@ type ('k1, 'v1, 'k2, 'v2) t = { f: 'k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit; merge: 'v2 -> 'v2 -> 'v2; (* Persistent state *) - provenance: ('k1, 'k2) ReactivePoolMapSet.t; - contributions: ('k2, 'k1, 'v2) ReactivePoolMapMap.t; + 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; @@ -33,10 +33,10 @@ and process_result = { (* Emit callback for steady-state — marks affected *) let add_single_contribution (t : (_, _, _, _) t) k2 v2 = - ReactivePoolMapSet.add t.provenance + StableMapSet.add t.provenance (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value k2); - ReactivePoolMapMap.replace t.contributions + StableMapMap.replace t.contributions (Stable.unsafe_of_value k2) (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value v2); @@ -44,10 +44,10 @@ let add_single_contribution (t : (_, _, _, _) t) k2 v2 = (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = - ReactivePoolMapSet.add t.provenance + StableMapSet.add t.provenance (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value k2); - ReactivePoolMapMap.replace t.contributions + StableMapMap.replace t.contributions (Stable.unsafe_of_value k2) (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value v2); @@ -60,8 +60,8 @@ let create ~f ~merge = { f; merge; - provenance = ReactivePoolMapSet.create (); - contributions = ReactivePoolMapMap.create (); + provenance = StableMapSet.create (); + contributions = StableMapMap.create (); target = StableMap.create (); scratch = StableMap.create (); affected = StableSet.create (); @@ -84,8 +84,8 @@ let create ~f ~merge = t let destroy t = - ReactivePoolMapSet.destroy t.provenance; - ReactivePoolMapMap.destroy t.contributions; + StableMapSet.destroy t.provenance; + StableMapMap.destroy t.contributions; StableMap.destroy t.target; StableMap.destroy t.scratch; StableSet.destroy t.affected; @@ -97,13 +97,13 @@ 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 = - ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 + StableMapMap.remove_from_inner_and_recycle_if_empty t.contributions k2 (Stable.unsafe_of_value t.current_k1); StableSet.add t.affected k2 let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; - ReactivePoolMapSet.drain_key t.provenance + StableMapSet.drain_key t.provenance (Stable.unsafe_of_value k1) t remove_one_contribution @@ -118,12 +118,12 @@ let merge_one_contribution (t : (_, _, _, _) t) _k1 v = let recompute_target (t : (_, _, _, _) t) k2 = let k2 = Stable.unsafe_to_value k2 in if - ReactivePoolMapMap.inner_cardinal t.contributions + StableMapMap.inner_cardinal t.contributions (Stable.unsafe_of_value k2) > 0 then ( t.merge_first <- true; - ReactivePoolMapMap.iter_inner_with t.contributions + StableMapMap.iter_inner_with t.contributions (Stable.unsafe_of_value k2) t merge_one_contribution; StableMap.replace t.target diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 6f9795a48c6..37ecd086da7 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -7,11 +7,11 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { right_get: 'k2 Stable.t -> 'v2 Stable.t Maybe.t; (* Persistent state *) left_entries: ('k1, 'v1) StableMap.t; - provenance: ('k1, 'k3) ReactivePoolMapSet.t; - contributions: ('k3, 'k1, 'v3) ReactivePoolMapMap.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) ReactivePoolMapSet.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; @@ -39,10 +39,10 @@ and process_result = { (* Emit callback for steady-state — marks affected *) let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = - ReactivePoolMapSet.add t.provenance + StableMapSet.add t.provenance (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value k3); - ReactivePoolMapMap.replace t.contributions + StableMapMap.replace t.contributions (Stable.unsafe_of_value k3) (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value v3); @@ -50,10 +50,10 @@ let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = - ReactivePoolMapSet.add t.provenance + StableMapSet.add t.provenance (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value k3); - ReactivePoolMapMap.replace t.contributions + StableMapMap.replace t.contributions (Stable.unsafe_of_value k3) (Stable.unsafe_of_value t.current_k1) (Stable.unsafe_of_value v3); @@ -69,11 +69,11 @@ let create ~key_of ~f ~merge ~right_get = merge; right_get; left_entries = StableMap.create (); - provenance = ReactivePoolMapSet.create (); - contributions = ReactivePoolMapMap.create (); + provenance = StableMapSet.create (); + contributions = StableMapMap.create (); target = StableMap.create (); left_to_right_key = StableMap.create (); - right_key_to_left_keys = ReactivePoolMapSet.create (); + right_key_to_left_keys = StableMapSet.create (); left_scratch = StableMap.create (); right_scratch = StableMap.create (); affected = StableSet.create (); @@ -97,11 +97,11 @@ let create ~key_of ~f ~merge ~right_get = let destroy t = StableMap.destroy t.left_entries; - ReactivePoolMapSet.destroy t.provenance; - ReactivePoolMapMap.destroy t.contributions; + StableMapSet.destroy t.provenance; + StableMapMap.destroy t.contributions; StableMap.destroy t.target; StableMap.destroy t.left_to_right_key; - ReactivePoolMapSet.destroy t.right_key_to_left_keys; + StableMapSet.destroy t.right_key_to_left_keys; StableMap.destroy t.left_scratch; StableMap.destroy t.right_scratch; StableSet.destroy t.affected; @@ -115,13 +115,13 @@ 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 = - ReactivePoolMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 + StableMapMap.remove_from_inner_and_recycle_if_empty t.contributions k3 (Stable.unsafe_of_value t.current_k1); StableSet.add t.affected k3 let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = t.current_k1 <- k1; - ReactivePoolMapSet.drain_key t.provenance + StableMapSet.drain_key t.provenance (Stable.unsafe_of_value k1) t remove_one_contribution_key @@ -132,7 +132,7 @@ let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = if Maybe.is_some mb then ( let old_k2 = Stable.unsafe_to_value (Maybe.unsafe_get mb) in StableMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); - ReactivePoolMapSet.remove_from_set_and_recycle_if_empty + StableMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys (Stable.unsafe_of_value old_k2) (Stable.unsafe_of_value k1)) @@ -144,7 +144,7 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = StableMap.replace t.left_to_right_key (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); - ReactivePoolMapSet.add t.right_key_to_left_keys + StableMapSet.add t.right_key_to_left_keys (Stable.unsafe_of_value k2) (Stable.unsafe_of_value k1); let right_val = @@ -170,12 +170,12 @@ let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = let recompute_target (t : (_, _, _, _, _, _) t) k3 = let k3 = Stable.unsafe_to_value k3 in if - ReactivePoolMapMap.inner_cardinal t.contributions + StableMapMap.inner_cardinal t.contributions (Stable.unsafe_of_value k3) > 0 then ( t.merge_first <- true; - ReactivePoolMapMap.iter_inner_with t.contributions + StableMapMap.iter_inner_with t.contributions (Stable.unsafe_of_value k3) t merge_one_contribution; StableMap.replace t.target @@ -220,7 +220,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = 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; - ReactivePoolMapSet.iter_inner_with t.right_key_to_left_keys + StableMapSet.iter_inner_with t.right_key_to_left_keys (Stable.unsafe_of_value k2) t reprocess_left_entry @@ -264,7 +264,7 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = StableMap.replace t.left_to_right_key (Stable.unsafe_of_value k1) (Stable.unsafe_of_value k2); - ReactivePoolMapSet.add t.right_key_to_left_keys + StableMapSet.add t.right_key_to_left_keys (Stable.unsafe_of_value k2) (Stable.unsafe_of_value k1); let right_val = diff --git a/analysis/reactive/src/StableMap.ml b/analysis/reactive/src/StableMap.ml index ee7aaaa7298..1a1653bc19b 100644 --- a/analysis/reactive/src/StableMap.ml +++ b/analysis/reactive/src/StableMap.ml @@ -65,9 +65,7 @@ let insert_absent t k 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 + 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; diff --git a/analysis/reactive/src/ReactivePoolMapMap.ml b/analysis/reactive/src/StableMapMap.ml similarity index 100% rename from analysis/reactive/src/ReactivePoolMapMap.ml rename to analysis/reactive/src/StableMapMap.ml diff --git a/analysis/reactive/src/ReactivePoolMapMap.mli b/analysis/reactive/src/StableMapMap.mli similarity index 100% rename from analysis/reactive/src/ReactivePoolMapMap.mli rename to analysis/reactive/src/StableMapMap.mli diff --git a/analysis/reactive/src/ReactivePoolMapSet.ml b/analysis/reactive/src/StableMapSet.ml similarity index 100% rename from analysis/reactive/src/ReactivePoolMapSet.ml rename to analysis/reactive/src/StableMapSet.ml diff --git a/analysis/reactive/src/ReactivePoolMapSet.mli b/analysis/reactive/src/StableMapSet.mli similarity index 100% rename from analysis/reactive/src/ReactivePoolMapSet.mli rename to analysis/reactive/src/StableMapSet.mli diff --git a/analysis/reactive/src/StableSet.ml b/analysis/reactive/src/StableSet.ml index dfa0bb91cec..5898b541f5d 100644 --- a/analysis/reactive/src/StableSet.ml +++ b/analysis/reactive/src/StableSet.ml @@ -142,7 +142,7 @@ 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 + 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; From 9cf620472d0cf83c086ee18d1e9f6b9d72df46a9 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 17:59:37 +0100 Subject: [PATCH 38/54] analysis/reactive: convert Source.table to StableMap and delete ReactiveHash Source.tables now uses StableMap for both tbl and pending, with proper destroy. ReactiveHash is no longer used anywhere and is removed. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Reactive.ml | 61 ++-- analysis/reactive/src/ReactiveHash.ml | 434 ------------------------- analysis/reactive/src/ReactiveHash.mli | 63 ---- analysis/reactive/test/AllocTest.ml | 14 +- 4 files changed, 42 insertions(+), 530 deletions(-) delete mode 100644 analysis/reactive/src/ReactiveHash.ml delete mode 100644 analysis/reactive/src/ReactiveHash.mli diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 31e85b0f979..62f2b3207ae 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -471,72 +471,77 @@ let stats t = t.stats let level t = t.level let name t = t.name -let unsafe_wave_push wave k v = - ReactiveWave.push wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value v) - (** {1 Source Collection} *) module Source = struct type ('k, 'v) tables = { - tbl: ('k, 'v) ReactiveHash.Map.t; - pending: ('k, 'v Maybe.t) ReactiveHash.Map.t; + tbl: ('k, 'v) StableMap.t; + pending: ('k, 'v Maybe.t) StableMap.t; } let apply_emit (tables : ('k, 'v) tables) k mv = - let k = Stable.unsafe_to_value k in let mv = Stable.unsafe_to_value mv in if Maybe.is_some mv then ( let v = Maybe.unsafe_get mv in - ReactiveHash.Map.replace tables.tbl k v; - ReactiveHash.Map.replace tables.pending k (Maybe.some v)) + StableMap.replace tables.tbl k (Stable.unsafe_of_value v); + StableMap.replace tables.pending k (Stable.unsafe_of_value (Maybe.some v))) else ( - ReactiveHash.Map.remove tables.tbl k; - ReactiveHash.Map.replace tables.pending k Maybe.none) + StableMap.remove tables.tbl k; + StableMap.replace tables.pending k + (Stable.unsafe_of_value Maybe.none)) let create ~name () = - let tbl : ('k, 'v) ReactiveHash.Map.t = ReactiveHash.Map.create () in + 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 ReactiveHash.Map for zero-alloc deduplication (last-write-wins). *) - let pending : ('k, 'v Maybe.t) ReactiveHash.Map.t = - ReactiveHash.Map.create () - in + 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 = ReactiveHash.Map.cardinal pending in + 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 + count; ReactiveWave.clear output_wave; - ReactiveHash.Map.iter_with unsafe_wave_push output_wave pending; - ReactiveHash.Map.clear pending; + StableMap.iter_with + (fun wave k v -> + ReactiveWave.push wave k (Stable.unsafe_of_value (Stable.unsafe_to_value v))) + output_wave pending; + StableMap.clear pending; notify_subscribers output_wave !subscribers) - else ReactiveHash.Map.clear pending + else StableMap.clear pending in - let destroy () = ReactiveWave.destroy output_wave in + let destroy () = + StableMap.destroy tbl; + StableMap.destroy pending; + ReactiveWave.destroy output_wave + in let my_info = Registry.register_node ~name ~level:0 ~process ~destroy ~stats:my_stats in - let iter_stable f k v = - f (Stable.unsafe_of_value k) (Stable.unsafe_of_value v) - in let collection = { name; subscribe = (fun h -> subscribers := h :: !subscribers); - iter = (fun f -> ReactiveHash.Map.iter_with iter_stable f tbl); + iter = + (fun f -> + StableMap.iter_with + (fun f k v -> + f k (Stable.unsafe_of_value (Stable.unsafe_to_value v))) + f tbl); get = (fun k -> - Maybe.of_stable - (Stable.unsafe_of_value - (ReactiveHash.Map.find_maybe tbl (Stable.unsafe_to_value k)))); - length = (fun () -> ReactiveHash.Map.cardinal tbl); + let mb = StableMap.find_maybe tbl k in + if Maybe.is_some mb then + Maybe.some (Stable.unsafe_of_value (Stable.unsafe_to_value (Maybe.unsafe_get mb))) + else Maybe.none); + length = (fun () -> StableMap.cardinal tbl); destroy; stats = my_stats; level = 0; diff --git a/analysis/reactive/src/ReactiveHash.ml b/analysis/reactive/src/ReactiveHash.ml deleted file mode 100644 index dbb746e43fe..00000000000 --- a/analysis/reactive/src/ReactiveHash.ml +++ /dev/null @@ -1,434 +0,0 @@ -(** Zero-allocation (steady-state) open-addressing hash maps and sets. - - Vendored from Hachis (François Pottier, Inria Paris). - Uses linear probing with void/tomb sentinels, power-of-2 capacity, - and Obj for type erasure. After tables reach steady-state capacity, - [clear] + [replace] cycles perform zero heap allocation. *) - -(* ---- Internal open-addressing table ---- *) - -(* Sentinels: physically unique values that can never be == to any user key. *) -let void = Obj.repr (ref ()) -let tomb = Obj.repr (ref ()) - -let[@inline] is_sentinel c = c == void || c == tomb -let[@inline] is_not_sentinel c = not (is_sentinel c) - -let log_alloc kind before_cap after_cap = - let _ = before_cap in - let _ = after_cap in - ReactiveAllocTrace.emit_alloc_kind kind - -type table = { - mutable population: int; (* number of live keys *) - mutable occupation: int; (* number of live keys + tombstones *) - mutable mask: int; (* capacity - 1 *) - mutable keys: Obj.t array; - mutable vals: Obj.t array; -} - -let initial_capacity = 8 - -(* Max occupancy: 105/128 ≈ 0.82 *) -let max_occupancy = 105 - -let[@inline] capacity t = Array.length t.keys -let[@inline] start t x = Hashtbl.hash x land t.mask -let[@inline] next t j = (j + 1) land t.mask -let[@inline] prev t j = (j - 1) land t.mask - -let[@inline] crowded_or_full occ cap = - 128 * occ > max_occupancy * cap || occ = cap - -let create_table () = - let cap = initial_capacity in - log_alloc ReactiveAllocTrace.Map_create 0 cap; - { - population = 0; - occupation = 0; - mask = cap - 1; - keys = Array.make cap void; - vals = [||]; - } - -let[@inline] ensure_vals t dummy = - if Array.length t.vals = 0 then ( - log_alloc ReactiveAllocTrace.Map_vals_init 0 (capacity t); - t.vals <- Array.make (capacity t) dummy) - -(* Zap slot j: replace with void or tomb, maintaining the invariant - that tomb is never followed by void. *) -let zap t j = - if Array.unsafe_get t.keys (next t j) == void then ( - Array.unsafe_set t.keys j void; - let k = ref (prev t j) in - let count = ref 1 in - while Array.unsafe_get t.keys !k == tomb do - Array.unsafe_set t.keys !k void; - k := prev t !k; - count := !count + 1 - done; - t.occupation <- t.occupation - !count) - else Array.unsafe_set t.keys j tomb - -(* Insert a key known to be absent, with no tombstones present. - Does NOT update population/occupation. Used by resize. *) -let rec add_absent t x v j = - let c = Array.unsafe_get t.keys j in - if c == void then ( - Array.unsafe_set t.keys j x; - Array.unsafe_set t.vals j v) - else add_absent t x v (next t j) - -let resize t new_cap = - log_alloc ReactiveAllocTrace.Table_resize (capacity t) new_cap; - let old_keys = t.keys in - let old_vals = t.vals in - let old_cap = capacity t in - t.mask <- new_cap - 1; - t.keys <- Array.make new_cap void; - (if Array.length old_vals > 0 then - let dummy = Array.unsafe_get old_vals 0 in - t.vals <- Array.make new_cap dummy); - for k = 0 to old_cap - 1 do - let c = Array.unsafe_get old_keys k in - if is_not_sentinel c then - add_absent t c (Array.unsafe_get old_vals k) (start t c) - done; - t.occupation <- t.population - -let[@inline] possibly_grow t = - let o = t.occupation and c = capacity t in - if crowded_or_full o c then resize t (2 * c) - -(* ---- mem ---- *) - -let rec mem_probe t x j = - let c = Array.unsafe_get t.keys j in - if c == void then false - else if c == tomb then mem_probe t x (next t j) - else if c = x then true - else mem_probe t x (next t j) - -let[@inline] table_mem t x = mem_probe t x (start t x) - -(* ---- find_value (raises Not_found) ---- *) - -let rec find_probe t x j = - let c = Array.unsafe_get t.keys j in - if c == void then raise Not_found - else if c == tomb then find_probe t x (next t j) - else if c = x then Array.unsafe_get t.vals j - else find_probe t x (next t j) - -let[@inline] table_find t x = find_probe t x (start t x) - -(* ---- find_maybe (zero-allocation) ---- *) - -let maybe_none_obj : Obj.t = Obj.repr Maybe.none - -let rec find_maybe_probe t x j = - let c = Array.unsafe_get t.keys j in - if c == void then maybe_none_obj - else if c == tomb then find_maybe_probe t x (next t j) - else if c = x then Array.unsafe_get t.vals j - else find_maybe_probe t x (next t j) - -let[@inline] table_find_maybe t x = find_maybe_probe t x (start t x) - -(* ---- replace ---- *) - -let rec replace_probe t x v j = - let c = Array.unsafe_get t.keys j in - if c == void then ( - t.occupation <- t.occupation + 1; - ensure_vals t v; - t.population <- t.population + 1; - Array.unsafe_set t.keys j x; - Array.unsafe_set t.vals j v; - true) - else if c == tomb then replace_aux t x v j (next t j) - else if c = x then ( - Array.unsafe_set t.keys j x; - Array.unsafe_set t.vals j v; - false) - else replace_probe t x v (next t j) - -and replace_aux t x v tomb_j j = - let c = Array.unsafe_get t.keys j in - if c == void then ( - (* not found; insert at tombstone slot *) - let j = tomb_j in - t.population <- t.population + 1; - Array.unsafe_set t.keys j x; - Array.unsafe_set t.vals j v; - true) - else if c == tomb then replace_aux t x v tomb_j (next t j) - else if c = x then ( - (* found beyond tombstone; move it back *) - Array.unsafe_set t.keys tomb_j c; - Array.unsafe_set t.vals tomb_j (Array.unsafe_get t.vals j); - zap t j; - let j = tomb_j in - Array.unsafe_set t.keys j x; - Array.unsafe_set t.vals j v; - false) - else replace_aux t x v tomb_j (next t j) - -let table_replace t x v = - let was_added = replace_probe t x v (start t x) in - if was_added then possibly_grow t - -(* ---- remove ---- *) - -let rec remove_probe t x j = - let c = Array.unsafe_get t.keys j in - if c == void then () - else if c == tomb then remove_probe t x (next t j) - else if c = x then ( - t.population <- t.population - 1; - zap t j) - else remove_probe t x (next t j) - -let[@inline] table_remove t x = remove_probe t x (start t x) - -(* ---- find_value_and_remove ---- *) - -let rec find_value_and_remove_probe t x j = - let c = Array.unsafe_get t.keys j in - if c == void then raise Not_found - else if c == tomb then find_value_and_remove_probe t x (next t j) - else if c = x then ( - let v = Array.unsafe_get t.vals j in - t.population <- t.population - 1; - zap t j; - v) - else find_value_and_remove_probe t x (next t j) - -let[@inline] table_find_value_and_remove t x = - find_value_and_remove_probe t x (start t x) - -(* ---- tighten ---- *) - -let rec possibly_shrink t new_cap = - if new_cap = initial_capacity || crowded_or_full t.population (new_cap / 2) - then (if new_cap < capacity t then resize t new_cap) - else possibly_shrink t (new_cap / 2) - -let table_tighten t = possibly_shrink t (capacity t) - -(* ---- clear ---- *) - -let table_clear t = - t.population <- 0; - t.occupation <- 0; - Array.fill t.keys 0 (capacity t) void - -(* ---- iter ---- *) - -let table_iter_kv f t = - if t.population > 0 then - for i = 0 to Array.length t.keys - 1 do - let c = Array.unsafe_get t.keys i in - if is_not_sentinel c then f c (Array.unsafe_get t.vals i) - done - -let table_iter_kv_with f arg t = - if t.population > 0 then - for i = 0 to Array.length t.keys - 1 do - let c = Array.unsafe_get t.keys i in - if is_not_sentinel c then f arg c (Array.unsafe_get t.vals i) - done - -let table_iter_k f t = - if t.population > 0 then - for i = 0 to Array.length t.keys - 1 do - let c = Array.unsafe_get t.keys i in - if is_not_sentinel c then f c - done - -let table_iter_k_with f arg t = - if t.population > 0 then - for i = 0 to Array.length t.keys - 1 do - let c = Array.unsafe_get t.keys i in - if is_not_sentinel c then f arg c - done - -exception Found - -(* ---- exists (early-exit scans) ---- *) - -let table_exists_k p t = - if t.population = 0 then false - else - try - for i = 0 to Array.length t.keys - 1 do - let c = Array.unsafe_get t.keys i in - if is_not_sentinel c && p c then raise Found - done; - false - with Found -> true - -let table_exists_k_with p arg t = - if t.population = 0 then false - else - try - for i = 0 to Array.length t.keys - 1 do - let c = Array.unsafe_get t.keys i in - if is_not_sentinel c && p arg c then raise Found - done; - false - with Found -> true - -(* ---- has_common_key ---- *) - -let table_has_common_key a b = - if a.population = 0 then false - else - try - for i = 0 to Array.length a.keys - 1 do - let c = Array.unsafe_get a.keys i in - if is_not_sentinel c && table_mem b c then raise Found - done; - false - with Found -> true - -(* ---- Set (keys only, no values) ---- *) - -(* For Set we reuse the same table but skip the value array. - We use replace_set which never touches vals. *) - -let rec set_replace_probe t x j = - let c = Array.unsafe_get t.keys j in - if c == void then ( - t.occupation <- t.occupation + 1; - t.population <- t.population + 1; - Array.unsafe_set t.keys j x; - true) - else if c == tomb then set_replace_aux t x j (next t j) - else if c = x then ( - Array.unsafe_set t.keys j x; - false) - else set_replace_probe t x (next t j) - -and set_replace_aux t x tomb_j j = - let c = Array.unsafe_get t.keys j in - if c == void then ( - let j = tomb_j in - t.population <- t.population + 1; - Array.unsafe_set t.keys j x; - true) - else if c == tomb then set_replace_aux t x tomb_j (next t j) - else if c = x then ( - Array.unsafe_set t.keys tomb_j c; - zap t j; - false) - else set_replace_aux t x tomb_j (next t j) - -let set_replace t x = - let was_added = set_replace_probe t x (start t x) in - if was_added then - let o = t.occupation and c = capacity t in - if crowded_or_full o c then ( - (* resize without value array *) - let old_keys = t.keys in - let old_cap = capacity t in - let new_cap = 2 * c in - log_alloc ReactiveAllocTrace.Set_resize c new_cap; - t.mask <- new_cap - 1; - t.keys <- Array.make new_cap void; - for k = 0 to old_cap - 1 do - let c = Array.unsafe_get old_keys k in - if is_not_sentinel c then ( - (* inline add_absent for keys only *) - let j = ref (start t c) in - while Array.unsafe_get t.keys !j != void do - j := next t !j - done; - Array.unsafe_set t.keys !j c) - done; - t.occupation <- t.population) - -let create_set () = - let cap = initial_capacity in - log_alloc ReactiveAllocTrace.Set_create 0 cap; - { - population = 0; - occupation = 0; - mask = cap - 1; - keys = Array.make cap void; - vals = [||]; - } - -(* ==== Public typed API ==== *) - -module Map = struct - type ('k, 'v) t = table - - let create () = create_table () - let clear t = table_clear t - - let replace (type k v) (t : (k, v) t) (k : k) (v : v) = - table_replace t (Obj.repr k) (Obj.repr v) - - let find_opt (type k v) (t : (k, v) t) (k : k) : v option = - match table_find t (Obj.repr k) with - | v -> Some (Obj.obj v : v) - | exception Not_found -> None - - let find (type k v) (t : (k, v) t) (k : k) : v = - (Obj.obj (table_find t (Obj.repr k)) : v) - - let find_maybe (type k v) (t : (k, v) t) (k : k) : v Maybe.t = - Obj.obj (table_find_maybe t (Obj.repr k)) - - let mem (type k v) (t : (k, v) t) (k : k) = table_mem t (Obj.repr k) - - let remove (type k v) (t : (k, v) t) (k : k) = table_remove t (Obj.repr k) - - let find_value_and_remove (type k v) (t : (k, v) t) (k : k) : v = - (Obj.obj (table_find_value_and_remove t (Obj.repr k)) : v) - - let tighten t = table_tighten t - - let iter (type k v) (f : k -> v -> unit) (t : (k, v) t) = - table_iter_kv (Obj.magic f : Obj.t -> Obj.t -> unit) t - - let iter_with (type a k v) (f : a -> k -> v -> unit) (arg : a) (t : (k, v) t) - = - table_iter_kv_with - (Obj.magic f : Obj.t -> Obj.t -> Obj.t -> unit) - (Obj.repr arg) t - - let has_common_key (type k v1 v2) (a : (k, v1) t) (b : (k, v2) t) : bool = - table_has_common_key a b - - let cardinal t = t.population -end - -module Set = struct - type 'k t = table - - let create () = create_set () - let clear t = table_clear t - - let add (type k) (t : k t) (k : k) = set_replace t (Obj.repr k) - - let remove (type k) (t : k t) (k : k) = table_remove t (Obj.repr k) - let mem (type k) (t : k t) (k : k) = table_mem t (Obj.repr k) - let tighten t = table_tighten t - - let iter (type k) (f : k -> unit) (t : k t) = - table_iter_k (Obj.magic f : Obj.t -> unit) t - - let iter_with (type a k) (f : a -> k -> unit) (arg : a) (t : k t) = - table_iter_k_with (Obj.magic f : Obj.t -> Obj.t -> unit) (Obj.repr arg) t - - let exists (type k) (p : k -> bool) (t : k t) = - table_exists_k (Obj.magic p : Obj.t -> bool) t - - let exists_with (type a k) (p : a -> k -> bool) (arg : a) (t : k t) = - table_exists_k_with (Obj.magic p : Obj.t -> Obj.t -> bool) (Obj.repr arg) t - - let cardinal t = t.population -end diff --git a/analysis/reactive/src/ReactiveHash.mli b/analysis/reactive/src/ReactiveHash.mli deleted file mode 100644 index a388be3c75f..00000000000 --- a/analysis/reactive/src/ReactiveHash.mli +++ /dev/null @@ -1,63 +0,0 @@ -(** Zero-allocation (steady-state) open-addressing hash maps and sets. - - Uses linear probing with void/tomb sentinels and Obj for type erasure. - After tables reach steady-state capacity, [clear] + [replace] cycles - perform zero heap allocation. *) - -module Map : sig - type ('k, 'v) t - - val create : unit -> ('k, 'v) t - val clear : ('k, 'v) t -> unit - val replace : ('k, 'v) t -> 'k -> 'v -> unit - val find_opt : ('k, 'v) t -> 'k -> 'v option - val find : ('k, 'v) t -> 'k -> 'v - val find_maybe : ('k, 'v) t -> 'k -> 'v Maybe.t - val mem : ('k, 'v) t -> 'k -> bool - val remove : ('k, 'v) t -> 'k -> unit - - val find_value_and_remove : ('k, 'v) t -> 'k -> 'v - (** [find_value_and_remove t k] removes [k] and returns its value. - Raises [Not_found] if [k] is absent. *) - - val tighten : ('k, 'v) t -> unit - (** [tighten t] shrinks capacity when occupancy is low. - Call after a batch of removals to reclaim backing-array space. *) - - val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit - - val iter_with : ('a -> 'k -> 'v -> unit) -> 'a -> ('k, 'v) t -> unit - (** [iter_with f arg t] calls [f arg k v] for each binding. - Unlike [iter (f arg) t], avoids allocating a closure when [f] - is a top-level function. Prefer this on hot paths. *) - - val has_common_key : ('k, 'v1) t -> ('k, 'v2) t -> bool - val cardinal : ('k, 'v) t -> int -end - -module Set : sig - type 'k t - - val create : unit -> 'k t - val clear : 'k t -> unit - val add : 'k t -> 'k -> unit - val remove : 'k t -> 'k -> unit - val mem : 'k t -> 'k -> bool - - val tighten : 'k t -> unit - - val iter : ('k -> unit) -> 'k t -> unit - - val iter_with : ('a -> 'k -> unit) -> 'a -> 'k t -> unit - (** See {!Map.iter_with}. *) - - val exists : ('k -> bool) -> 'k t -> bool - (** Returns [true] if any element satisfies the predicate. - Stops scanning as soon as one element matches. *) - - val exists_with : ('a -> 'k -> bool) -> 'a -> 'k t -> bool - (** [exists_with p arg t] is like [exists (p arg) t] but avoids closure - allocation for top-level predicates. *) - - val cardinal : 'k t -> int -end diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 14c9343f924..6d4350b73d9 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -207,7 +207,7 @@ let test_union_alloc () = (* ---- Join allocation ---- *) let test_join_alloc_n n = - let right_tbl = ReactiveHash.Map.create () in + let right_tbl = StableMap.create () in let state = ReactiveJoin.create ~key_of:(fun k _v -> k) @@ -215,14 +215,18 @@ let test_join_alloc_n n = if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) ~merge:(fun _l r -> r) ~right_get:(fun k -> - Maybe.of_stable - (Stable.unsafe_of_value - (ReactiveHash.Map.find_maybe right_tbl (Stable.unsafe_to_value k)))) + let mb = StableMap.find_maybe right_tbl k in + if Maybe.is_some mb then + Maybe.some + (Stable.unsafe_of_value + (Stable.unsafe_to_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 - ReactiveHash.Map.replace right_tbl i (i * 10) + 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) From bf1fe32dac1285ff9fb2d063a2fa80431cfa1056 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 18:01:38 +0100 Subject: [PATCH 39/54] analysis/reactive: rename ReactiveWave to StableWave and delete unused ReactiveTable ReactiveWave is allocator-backed, so rename to StableWave for consistency. ReactiveTable had no production usage and is removed along with its test. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Reactive.ml | 64 ++++----- analysis/reactive/src/Reactive.mli | 4 +- .../reactive/src/ReactiveFileCollection.ml | 22 +-- analysis/reactive/src/ReactiveFixpoint.ml | 40 +++--- analysis/reactive/src/ReactiveFixpoint.mli | 10 +- analysis/reactive/src/ReactiveFlatMap.ml | 16 +-- analysis/reactive/src/ReactiveFlatMap.mli | 2 +- analysis/reactive/src/ReactiveJoin.ml | 16 +-- analysis/reactive/src/ReactiveJoin.mli | 2 +- analysis/reactive/src/ReactiveTable.ml | 55 ------- analysis/reactive/src/ReactiveTable.mli | 45 ------ analysis/reactive/src/ReactiveUnion.ml | 16 +-- analysis/reactive/src/ReactiveUnion.mli | 2 +- .../src/{ReactiveWave.ml => StableWave.ml} | 0 .../src/{ReactiveWave.mli => StableWave.mli} | 0 analysis/reactive/test/AllocTest.ml | 84 +++++------ analysis/reactive/test/GlitchFreeTest.ml | 2 +- analysis/reactive/test/ReactiveTest.ml | 1 - analysis/reactive/test/TableTest.ml | 136 ------------------ analysis/reactive/test/TestHelpers.ml | 34 ++--- analysis/reactive/test/dune | 3 +- 21 files changed, 158 insertions(+), 396 deletions(-) delete mode 100644 analysis/reactive/src/ReactiveTable.ml delete mode 100644 analysis/reactive/src/ReactiveTable.mli rename analysis/reactive/src/{ReactiveWave.ml => StableWave.ml} (100%) rename analysis/reactive/src/{ReactiveWave.mli => StableWave.mli} (100%) delete mode 100644 analysis/reactive/test/TableTest.ml diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 62f2b3207ae..30e28c3415a 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -9,9 +9,9 @@ (** {1 Waves} *) -type ('k, 'v) wave = ('k, 'v Maybe.t) ReactiveWave.t +type ('k, 'v) wave = ('k, 'v Maybe.t) StableWave.t -let create_wave () = ReactiveWave.create () +let create_wave () = StableWave.create () (** {1 Statistics} *) @@ -506,10 +506,10 @@ module Source = struct if count > 0 then ( my_stats.deltas_emitted <- my_stats.deltas_emitted + 1; my_stats.entries_emitted <- my_stats.entries_emitted + count; - ReactiveWave.clear output_wave; + StableWave.clear output_wave; StableMap.iter_with (fun wave k v -> - ReactiveWave.push wave k (Stable.unsafe_of_value (Stable.unsafe_to_value v))) + StableWave.push wave k (Stable.unsafe_of_value (Stable.unsafe_to_value v))) output_wave pending; StableMap.clear pending; notify_subscribers output_wave !subscribers) @@ -519,7 +519,7 @@ module Source = struct let destroy () = StableMap.destroy tbl; StableMap.destroy pending; - ReactiveWave.destroy output_wave + StableWave.destroy output_wave in let my_info = Registry.register_node ~name ~level:0 ~process ~destroy ~stats:my_stats @@ -549,12 +549,12 @@ module Source = struct } in - let emit (input_wave : ('k, 'v Maybe.t) ReactiveWave.t) = - let count = ReactiveWave.count input_wave 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 *) - ReactiveWave.iter_with input_wave apply_emit tables; + 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 () @@ -614,7 +614,7 @@ module FlatMap = struct src.subscribe (fun wave -> Registry.inc_inflight_node src.node; incr pending_count; - ReactiveWave.iter_with wave ReactiveFlatMap.push state; + StableWave.iter_with wave ReactiveFlatMap.push state; Registry.mark_dirty_node my_info); (* Initialize from existing data *) @@ -695,13 +695,13 @@ module Join = struct left.subscribe (fun wave -> Registry.inc_inflight_node left.node; incr left_pending_count; - ReactiveWave.iter_with wave ReactiveJoin.push_left state; + 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; - ReactiveWave.iter_with wave ReactiveJoin.push_right state; + StableWave.iter_with wave ReactiveJoin.push_right state; Registry.mark_dirty_node my_info); (* Initialize from existing data *) @@ -780,13 +780,13 @@ module Union = struct left.subscribe (fun wave -> Registry.inc_inflight_node left.node; incr left_pending_count; - ReactiveWave.iter_with wave ReactiveUnion.push_left state; + 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; - ReactiveWave.iter_with wave ReactiveUnion.push_right state; + StableWave.iter_with wave ReactiveUnion.push_right state; Registry.mark_dirty_node my_info); (* Initialize from existing data - process left then right *) @@ -811,7 +811,7 @@ end module Fixpoint = struct let stable_wave_map_replace pending k v = StableMap.replace pending k v - let stable_wave_push wave k v = ReactiveWave.push wave 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.inner) t) () : ('k, unit) t = @@ -837,8 +837,8 @@ module Fixpoint = struct 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 = ReactiveWave.create ~max_entries:max_root_wave_entries () in - let edge_wave = ReactiveWave.create ~max_entries:max_edge_wave_entries () 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 @@ -860,8 +860,8 @@ module Fixpoint = struct Registry.dec_inflight_node edges.node consumed_edges; (* Dump pending maps into waves *) - ReactiveWave.clear root_wave; - ReactiveWave.clear edge_wave; + 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; @@ -876,7 +876,7 @@ module Fixpoint = struct ReactiveFixpoint.apply_wave state ~roots:root_wave ~edges:edge_wave; let out_wave = ReactiveFixpoint.output_wave state in - let out_count = ReactiveWave.count out_wave 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; @@ -886,8 +886,8 @@ module Fixpoint = struct let destroy () = StableMap.destroy root_pending; StableMap.destroy edge_pending; - ReactiveWave.destroy root_wave; - ReactiveWave.destroy edge_wave; + StableWave.destroy root_wave; + StableWave.destroy edge_wave; ReactiveFixpoint.destroy state in let my_info = @@ -903,30 +903,30 @@ module Fixpoint = struct init.subscribe (fun wave -> Registry.inc_inflight_node init.node; init_pending_count := !init_pending_count + 1; - ReactiveWave.iter_with wave stable_wave_map_replace root_pending; + 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; - ReactiveWave.iter_with wave stable_wave_map_replace edge_pending; + StableWave.iter_with wave stable_wave_map_replace edge_pending; Registry.mark_dirty_node my_info); (* Initialize from existing data *) let init_roots_wave = - ReactiveWave.create ~max_entries:(max 1 (init.length ())) () + StableWave.create ~max_entries:(max 1 (init.length ())) () in - let init_edges_wave : ('k, 'k StableList.inner) ReactiveWave.t = - ReactiveWave.create ~max_entries:(max 1 (edges.length ())) () + let init_edges_wave : ('k, 'k StableList.inner) StableWave.t = + StableWave.create ~max_entries:(max 1 (edges.length ())) () in - ReactiveWave.clear init_roots_wave; - ReactiveWave.clear init_edges_wave; - init.iter (fun k _unit -> ReactiveWave.push init_roots_wave k Stable.unit); - edges.iter (fun k succs -> ReactiveWave.push init_edges_wave k succs); + 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; - ReactiveWave.destroy init_roots_wave; - ReactiveWave.destroy init_edges_wave; + StableWave.destroy init_roots_wave; + StableWave.destroy init_edges_wave; { name; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index 37ae6386d82..e3b9c0e4bad 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -9,7 +9,7 @@ (** {1 Waves} *) -type ('k, 'v) wave = ('k, 'v Maybe.t) ReactiveWave.t +type ('k, 'v) wave = ('k, 'v Maybe.t) StableWave.t (** Mutable wave buffer carrying batch entries *) (** {1 Statistics} *) @@ -99,7 +99,7 @@ module Source : sig val create : name:string -> unit -> - ('k, 'v) t * (('k, 'v Maybe.t) ReactiveWave.t -> 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 diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index a6671f081e2..a1937043e70 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -23,8 +23,8 @@ type ('raw, 'v) internal = { type ('raw, 'v) t = { internal: ('raw, 'v) internal; collection: (string, 'v) Reactive.t; - emit: (string, 'v Maybe.t) ReactiveWave.t -> unit; - scratch_wave: (string, 'v Maybe.t) ReactiveWave.t; + 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 *) @@ -32,7 +32,7 @@ type ('raw, 'v) t = { let create ~read_file ~process : ('raw, 'v) t = let internal = {cache = Hashtbl.create 256; read_file; process} in let collection, emit = Reactive.Source.create ~name:"file_collection" () in - let scratch_wave = ReactiveWave.create () in + let scratch_wave = StableWave.create () in {internal; collection; emit; scratch_wave} (** Get the collection interface for composition *) @@ -40,8 +40,8 @@ let to_collection t : (string, 'v) Reactive.t = t.collection (** Emit a single set entry *) let emit_set t path value = - ReactiveWave.clear t.scratch_wave; - ReactiveWave.push t.scratch_wave + 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 @@ -66,7 +66,7 @@ let process_files t paths = (** 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 = - ReactiveWave.clear t.scratch_wave; + StableWave.clear t.scratch_wave; let count = ref 0 in List.iter (fun path -> @@ -77,7 +77,7 @@ let process_files_batch t paths = 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); - ReactiveWave.push t.scratch_wave + StableWave.push t.scratch_wave (Stable.unsafe_of_value path) (Stable.unsafe_of_value (Maybe.some value)); incr count) @@ -88,21 +88,21 @@ let process_files_batch t paths = (** Remove a file *) let remove t path = Hashtbl.remove t.internal.cache path; - ReactiveWave.clear t.scratch_wave; - ReactiveWave.push t.scratch_wave + 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 = - ReactiveWave.clear t.scratch_wave; + 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; - ReactiveWave.push t.scratch_wave + StableWave.push t.scratch_wave (Stable.unsafe_of_value path) Maybe.none_stable; incr count)) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 633100c4c84..4d19b5ffe24 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -20,7 +20,7 @@ type 'k t = { edge_map: ('k, 'k StableList.inner) StableMap.t; pred_map: ('k, 'k) StableMapSet.t; roots: 'k StableSet.t; - output_wave: ('k, unit Maybe.t) ReactiveWave.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; @@ -402,7 +402,7 @@ let create ~max_nodes ~max_edges = edge_map = StableMap.create (); pred_map = StableMapSet.create (); roots = StableSet.create (); - output_wave = ReactiveWave.create ~max_entries:max_nodes (); + output_wave = StableWave.create ~max_entries:max_nodes (); deleted_nodes = StableSet.create (); rederive_pending = StableSet.create (); expansion_seen = StableSet.create (); @@ -448,14 +448,14 @@ let destroy t = StableQueue.destroy t.added_roots_queue; StableQueue.destroy t.edge_change_queue; StableSet.destroy t.metrics.scratch_reachable; - ReactiveWave.destroy t.output_wave + StableWave.destroy t.output_wave let output_wave t = t.output_wave -type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t -type 'k edge_wave = ('k, 'k StableList.inner Maybe.t) ReactiveWave.t -type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t -type 'k root_snapshot = ('k, unit) ReactiveWave.t -type 'k edge_snapshot = ('k, 'k StableList.inner) ReactiveWave.t +type 'k root_wave = ('k, unit Maybe.t) StableWave.t +type 'k edge_wave = ('k, 'k StableList.inner 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.inner) StableWave.t let iter_current t f = StableSet.iter_with (fun f k -> f k Stable.unit) f t.current @@ -524,8 +524,8 @@ let initialize t ~roots ~edges = StableSet.clear t.roots; StableMap.clear t.edge_map; StableMapSet.clear t.pred_map; - ReactiveWave.iter roots (fun k _ -> StableSet.add t.roots k); - ReactiveWave.iter edges (fun k successors -> + StableWave.iter roots (fun k _ -> StableSet.add t.roots k); + StableWave.iter edges (fun k successors -> apply_edge_update t ~src:(Stable.unsafe_to_value k) ~new_successors:successors); recompute_current t @@ -560,7 +560,7 @@ let add_live t k = if not (StableSet.mem t.current (stable_key k)) then ( StableSet.add t.current (stable_key k); if not (StableSet.mem t.deleted_nodes (stable_key k)) then - ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + StableWave.push t.output_wave (Stable.unsafe_of_value k) (Maybe.to_stable (Maybe.some Stable.unit)); enqueue_expand t k) @@ -624,7 +624,7 @@ let apply_root_mutation t k mv = let emit_removal t k () = if not (StableSet.mem t.current (stable_key k)) then - ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) Maybe.none_stable + StableWave.push t.output_wave (Stable.unsafe_of_value k) Maybe.none_stable let rebuild_edge_change_queue t src _succs = StableQueue.push t.edge_change_queue src @@ -651,14 +651,14 @@ let apply_list t ~roots ~edges = (* Phase 1a: scan init entries — seed delete queue for removed roots, buffer added roots for later expansion *) - ReactiveWave.iter_with roots + StableWave.iter_with roots (fun t k mv -> scan_root_entry t (Stable.unsafe_to_value k) (Stable.unsafe_to_value mv)) t; (* Phase 1b: scan edge entries — seed delete queue for removed targets, store new_succs and has_new_edge for later phases *) - ReactiveWave.iter_with edges + StableWave.iter_with edges (fun t src mv -> let mv = Stable.unsafe_to_value mv in let mv = @@ -689,7 +689,7 @@ let apply_list t ~roots ~edges = ~deleted_nodes:t.deleted_nodes ~old_successors:(old_successors t); (* Phase 3: apply root and edge mutations *) - ReactiveWave.iter_with roots + StableWave.iter_with roots (fun t k mv -> apply_root_mutation t (Stable.unsafe_to_value k) (Stable.unsafe_to_value mv)) @@ -781,7 +781,7 @@ let apply_list t ~roots ~edges = let output_entries_list = if Invariants.enabled then ( let entries = ref [] in - ReactiveWave.iter t.output_wave (fun k v_opt -> + StableWave.iter t.output_wave (fun k v_opt -> entries := (Stable.unsafe_to_value k, Stable.unsafe_to_value v_opt) :: !entries); !entries) @@ -800,8 +800,8 @@ let apply_list t ~roots ~edges = let full_node_work, full_edge_work = compute_reachable ~visited:t.metrics.scratch_reachable t in - let init_count = ReactiveWave.count roots in - let edge_count = ReactiveWave.count edges 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 @@ -811,12 +811,12 @@ let apply_list t ~roots ~edges = + m.expansion_edges_scanned in Metrics.update ~init_entries:init_count ~edge_entries:edge_count - ~output_entries:(ReactiveWave.count t.output_wave) + ~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 = - ReactiveWave.clear t.output_wave; + 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 b367cf4f8e7..79a22752c09 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -3,11 +3,11 @@ type 'k t This implementation uses fixed-capacity arrays allocated in [create]. *) -type 'k root_wave = ('k, unit Maybe.t) ReactiveWave.t -type 'k edge_wave = ('k, 'k StableList.inner Maybe.t) ReactiveWave.t -type 'k output_wave = ('k, unit Maybe.t) ReactiveWave.t -type 'k root_snapshot = ('k, unit) ReactiveWave.t -type 'k edge_snapshot = ('k, 'k StableList.inner) ReactiveWave.t +type 'k root_wave = ('k, unit Maybe.t) StableWave.t +type 'k edge_wave = ('k, 'k StableList.inner 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.inner) StableWave.t val create : max_nodes:int -> max_edges:int -> 'k t (** Create an empty state with fixed capacities. diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 99312f72e1a..4b998491eee 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -11,7 +11,7 @@ type ('k1, 'v1, 'k2, 'v2) t = { scratch: ('k1, 'v1 Maybe.t) StableMap.t; affected: 'k2 StableSet.t; (* Pre-allocated output buffer *) - output_wave: ('k2, 'v2 Maybe.t) ReactiveWave.t; + output_wave: ('k2, 'v2 Maybe.t) StableWave.t; (* Emit callback state — allocated once, reused per entry *) mutable current_k1: 'k1; emit_fn: 'k2 -> 'v2 -> unit; @@ -65,7 +65,7 @@ let create ~f ~merge = target = StableMap.create (); scratch = StableMap.create (); affected = StableSet.create (); - output_wave = ReactiveWave.create (); + output_wave = StableWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k2 v2 -> add_single_contribution t k2 v2); result = @@ -89,7 +89,7 @@ let destroy t = StableMap.destroy t.target; StableMap.destroy t.scratch; StableSet.destroy t.affected; - ReactiveWave.destroy t.output_wave + StableWave.destroy t.output_wave let output_wave t = t.output_wave @@ -129,12 +129,12 @@ let recompute_target (t : (_, _, _, _) t) k2 = StableMap.replace t.target (Stable.unsafe_of_value k2) (Stable.unsafe_of_value t.merge_acc); - ReactiveWave.push t.output_wave + StableWave.push t.output_wave (Stable.unsafe_of_value k2) (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( StableMap.remove t.target (Stable.unsafe_of_value k2); - ReactiveWave.push t.output_wave + StableWave.push t.output_wave (Stable.unsafe_of_value k2) Maybe.none_stable) @@ -165,17 +165,17 @@ let process (t : (_, _, _, _) t) = r.removes_emitted <- 0; StableSet.clear t.affected; - ReactiveWave.clear t.output_wave; + 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 = ReactiveWave.count t.output_wave in + let num_entries = StableWave.count t.output_wave in r.entries_emitted <- num_entries; if num_entries > 0 then - ReactiveWave.iter_with t.output_wave count_output_entry r; + StableWave.iter_with t.output_wave count_output_entry r; r let init_entry (t : (_, _, _, _) t) k1 v1 = diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index 8e1d13d7829..f7c34163029 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -22,7 +22,7 @@ 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) ReactiveWave.t +val output_wave : ('k1, 'v1, 'k2, 'v2) t -> ('k2, 'v2 Maybe.t) StableWave.t (** The owned output wave populated by [process]. *) val push : diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 37ecd086da7..732fa91e498 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -17,7 +17,7 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { right_scratch: ('k2, 'v2 Maybe.t) StableMap.t; affected: 'k3 StableSet.t; (* Pre-allocated output buffer *) - output_wave: ('k3, 'v3 Maybe.t) ReactiveWave.t; + output_wave: ('k3, 'v3 Maybe.t) StableWave.t; (* Emit callback state — allocated once, reused per entry *) mutable current_k1: 'k1; emit_fn: 'k3 -> 'v3 -> unit; @@ -77,7 +77,7 @@ let create ~key_of ~f ~merge ~right_get = left_scratch = StableMap.create (); right_scratch = StableMap.create (); affected = StableSet.create (); - output_wave = ReactiveWave.create (); + output_wave = StableWave.create (); current_k1 = Obj.magic (); emit_fn = (fun k3 v3 -> add_single_contribution t k3 v3); result = @@ -105,7 +105,7 @@ let destroy t = StableMap.destroy t.left_scratch; StableMap.destroy t.right_scratch; StableSet.destroy t.affected; - ReactiveWave.destroy t.output_wave + StableWave.destroy t.output_wave let output_wave t = t.output_wave @@ -181,12 +181,12 @@ let recompute_target (t : (_, _, _, _, _, _) t) k3 = StableMap.replace t.target (Stable.unsafe_of_value k3) (Stable.unsafe_of_value t.merge_acc); - ReactiveWave.push t.output_wave + StableWave.push t.output_wave (Stable.unsafe_of_value k3) (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( StableMap.remove t.target (Stable.unsafe_of_value k3); - ReactiveWave.push t.output_wave + StableWave.push t.output_wave (Stable.unsafe_of_value k3) Maybe.none_stable) @@ -238,7 +238,7 @@ let process (t : (_, _, _, _, _, _) t) = r.removes_emitted <- 0; StableSet.clear t.affected; - ReactiveWave.clear t.output_wave; + 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; @@ -248,10 +248,10 @@ let process (t : (_, _, _, _, _, _) t) = StableSet.iter_with recompute_target t t.affected; - let num_entries = ReactiveWave.count t.output_wave in + let num_entries = StableWave.count t.output_wave in r.entries_emitted <- num_entries; if num_entries > 0 then - ReactiveWave.iter_with t.output_wave count_output_entry r; + StableWave.iter_with t.output_wave count_output_entry r; r let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index 6cc84434b07..a7c25480c07 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -25,7 +25,7 @@ val destroy : ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> unit afterwards. *) val output_wave : - ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> ('k3, 'v3 Maybe.t) ReactiveWave.t + ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t -> ('k3, 'v3 Maybe.t) StableWave.t (** The owned output wave populated by [process]. *) val push_left : diff --git a/analysis/reactive/src/ReactiveTable.ml b/analysis/reactive/src/ReactiveTable.ml deleted file mode 100644 index e6047cb8023..00000000000 --- a/analysis/reactive/src/ReactiveTable.ml +++ /dev/null @@ -1,55 +0,0 @@ -type 'a t = Obj.t Allocator.Block.t - -let length_slot = 0 -let data_offset = 1 - -let length (t : 'a t) : int = Obj.magic (Allocator.Block.get t length_slot) - -let capacity (t : 'a t) = Allocator.Block.capacity t - data_offset - -let create ~initial_capacity : 'a t = - if initial_capacity < 0 then invalid_arg "ReactiveTable.create"; - let t = Allocator.Block.create ~capacity:(initial_capacity + data_offset) in - Allocator.Block.set t length_slot (Obj.magic (Stable.int 0)); - t - -let destroy = Allocator.Block.destroy - -let clear (t : 'a t) = - Allocator.Block.set t length_slot (Obj.magic (Stable.int 0)) - -let ensure_capacity (t : 'a t) needed = - let old_capacity = capacity t in - if needed > old_capacity then ( - let new_capacity = ref (max 1 old_capacity) in - while !new_capacity < needed do - new_capacity := !new_capacity * 2 - done; - Allocator.Block.resize t ~capacity:(!new_capacity + data_offset)) - -let get (t : 'a t) index = - let len = length t in - if index < 0 || index >= len then invalid_arg "ReactiveTable.get"; - Obj.magic (Allocator.Block.get t (index + data_offset)) - -let set (t : 'a t) index value = - let len = length t in - if index < 0 || index >= len then invalid_arg "ReactiveTable.set"; - Allocator.Block.set t (index + data_offset) (Obj.magic value) - -let push (t : 'a t) value = - let len = length t in - let next_len = len + 1 in - ensure_capacity t next_len; - Allocator.Block.set t (len + data_offset) (Obj.magic value); - Allocator.Block.set t length_slot (Obj.magic (Stable.int next_len)) - -let pop (t : 'a t) = - let len = length t in - if len = 0 then invalid_arg "ReactiveTable.pop"; - let last = Obj.magic (Allocator.Block.get t (len - 1 + data_offset)) in - Allocator.Block.set t length_slot (Obj.magic (Stable.int (len - 1))); - last - -let shrink_to_fit (t : 'a t) = - Allocator.Block.resize t ~capacity:(length t + data_offset) diff --git a/analysis/reactive/src/ReactiveTable.mli b/analysis/reactive/src/ReactiveTable.mli deleted file mode 100644 index 8dfed053eba..00000000000 --- a/analysis/reactive/src/ReactiveTable.mli +++ /dev/null @@ -1,45 +0,0 @@ -type 'a t - -val create : initial_capacity:int -> 'a t -(** Create an extensible stable table. - - Stored values are raw OCaml values kept outside the GC's scanned heap. - This is only safe for immediates, or for heap values that are: - 1. promoted out of the minor heap, and - 2. kept reachable through normal OCaml roots elsewhere. - - Intended reactive protocol: - 1. Produce a wave of fresh OCaml values on the heap. - 2. Promote them out of the minor heap before stable publication. - 3. Insert them into stable reactive tables during the allocation-free - processing phase. - 4. After the iteration finishes, flush/remove table entries as needed. - 5. Only then drop the ordinary OCaml roots for removed values. - - Violating this protocol is unsafe: - - minor-heap values may move, leaving stale pointers stable - - unrooted major-heap values may be reclaimed *) - -val destroy : 'a t -> unit -(** Release the table storage. The handle must not be used afterwards. *) - -val length : 'a t -> int -(** Number of elements currently stored in the table. *) - -val capacity : 'a t -> int -(** Current table capacity, in elements. *) - -val clear : 'a t -> unit -(** Remove all elements from the table without releasing its storage. *) - -val get : 'a t -> int -> 'a Stable.t -val set : 'a t -> int -> 'a Stable.t -> unit - -val push : 'a t -> 'a Stable.t -> unit -(** Append an element, growing via the allocator when needed. *) - -val pop : 'a t -> 'a Stable.t -(** Remove and return the last element. *) - -val shrink_to_fit : 'a t -> unit -(** Shrink storage capacity down to the current length. *) diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index 1befcd05f35..c81d610e88c 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -8,7 +8,7 @@ type ('k, 'v) 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) ReactiveWave.t; + output_wave: ('k, 'v Maybe.t) StableWave.t; result: process_result; } @@ -30,7 +30,7 @@ let create ~merge = left_scratch = StableMap.create (); right_scratch = StableMap.create (); affected = StableSet.create (); - output_wave = ReactiveWave.create (); + output_wave = StableWave.create (); result = { entries_received = 0; @@ -49,7 +49,7 @@ let destroy t = StableMap.destroy t.left_scratch; StableMap.destroy t.right_scratch; StableSet.destroy t.affected; - ReactiveWave.destroy t.output_wave + StableWave.destroy t.output_wave let output_wave t = t.output_wave @@ -103,23 +103,23 @@ let recompute_affected_entry t k = in StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value merged); - ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + StableWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some merged))) else let v = Stable.unsafe_to_value (Maybe.unsafe_get lv) in StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); - ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + StableWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v))) else if has_right then ( let v = Stable.unsafe_to_value (Maybe.unsafe_get rv) in StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); - ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) + StableWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v))) else ( StableMap.remove t.target (Stable.unsafe_of_value k); - ReactiveWave.push t.output_wave (Stable.unsafe_of_value k) Maybe.none_stable); + StableWave.push t.output_wave (Stable.unsafe_of_value 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 @@ -141,7 +141,7 @@ let process t = StableMap.clear t.right_scratch; if StableSet.cardinal t.affected > 0 then ( - ReactiveWave.clear t.output_wave; + StableWave.clear t.output_wave; StableSet.iter_with recompute_affected_entry t t.affected); r diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index cfa1536185b..f4fe1a25742 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -20,7 +20,7 @@ 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) ReactiveWave.t +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 diff --git a/analysis/reactive/src/ReactiveWave.ml b/analysis/reactive/src/StableWave.ml similarity index 100% rename from analysis/reactive/src/ReactiveWave.ml rename to analysis/reactive/src/StableWave.ml diff --git a/analysis/reactive/src/ReactiveWave.mli b/analysis/reactive/src/StableWave.mli similarity index 100% rename from analysis/reactive/src/ReactiveWave.mli rename to analysis/reactive/src/StableWave.mli diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 6d4350b73d9..91d297e20e4 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -33,25 +33,25 @@ let print_stable_snapshot label = 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 = ReactiveWave.create ~max_entries:1 () in - let edge_snap = ReactiveWave.create ~max_entries:n () in - let remove_root = ReactiveWave.create ~max_entries:1 () in - let add_root = ReactiveWave.create ~max_entries:1 () in - let no_edges = ReactiveWave.create ~max_entries:1 () in + 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 *) - ReactiveWave.push root_snap (stable_int 0) stable_unit; + StableWave.push root_snap (stable_int 0) stable_unit; for i = 0 to n - 2 do - ReactiveWave.push edge_snap (stable_int i) + StableWave.push edge_snap (stable_int i) (Stable.of_value (StableList.unsafe_inner_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 *) - ReactiveWave.push remove_root (stable_int 0) Maybe.none_stable; - ReactiveWave.push add_root (stable_int 0) + 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 *) @@ -69,11 +69,11 @@ let test_fixpoint_alloc_n n = ReactiveFixpoint.apply_wave state ~roots:add_root ~edges:no_edges done; assert (ReactiveFixpoint.current_length state = n); - ReactiveWave.destroy root_snap; - ReactiveWave.destroy edge_snap; - ReactiveWave.destroy remove_root; - ReactiveWave.destroy add_root; - ReactiveWave.destroy no_edges; + 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 @@ -305,13 +305,13 @@ let test_reactive_join_alloc_n n = assert (Reactive.length joined = n); (* Pre-build waves for the hot loop: toggle all left entries *) - let remove_wave = ReactiveWave.create ~max_entries:n () in + let remove_wave = StableWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (stable_int i) Maybe.none_stable + StableWave.push remove_wave (stable_int i) Maybe.none_stable done; - let add_wave = ReactiveWave.create ~max_entries:n () in + let add_wave = StableWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push add_wave (stable_int i) + StableWave.push add_wave (stable_int i) (Maybe.to_stable (Maybe.some (Stable.int i))) done; @@ -332,8 +332,8 @@ let test_reactive_join_alloc_n n = emit_left add_wave done; assert (Reactive.length joined = n); - ReactiveWave.destroy remove_wave; - ReactiveWave.destroy add_wave; + StableWave.destroy remove_wave; + StableWave.destroy add_wave; Reactive.destroy_graph (); words_since () / iters @@ -359,10 +359,10 @@ let test_reactive_fixpoint_alloc_n n = let edges, emit_edges = Reactive.Source.create ~name:"edges" () in (* Chain graph: 0 -> 1 -> 2 -> ... -> n-1 *) - let edge_wave = ReactiveWave.create ~max_entries:(max 1 (n - 1)) () in - ReactiveWave.clear edge_wave; + let edge_wave = StableWave.create ~max_entries:(max 1 (n - 1)) () in + StableWave.clear edge_wave; for i = 0 to n - 2 do - ReactiveWave.push edge_wave (stable_int i) + StableWave.push edge_wave (stable_int i) (Maybe.to_stable (Maybe.some edge_values_stable.(i))) done; emit_edges edge_wave; @@ -373,10 +373,10 @@ let test_reactive_fixpoint_alloc_n n = assert (Reactive.length reachable = n); (* Pre-build waves for the hot loop *) - let remove_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push remove_wave (stable_int 0) Maybe.none_stable; - let add_wave = ReactiveWave.create ~max_entries:1 () in - ReactiveWave.push add_wave (stable_int 0) + 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 *) @@ -395,9 +395,9 @@ let test_reactive_fixpoint_alloc_n n = emit_root add_wave done; assert (Reactive.length reachable = n); - ReactiveWave.destroy edge_wave; - ReactiveWave.destroy remove_wave; - ReactiveWave.destroy add_wave; + StableWave.destroy edge_wave; + StableWave.destroy remove_wave; + StableWave.destroy add_wave; Reactive.destroy_graph (); words_since () / iters @@ -428,13 +428,13 @@ let test_reactive_union_alloc_n n = assert (Reactive.length merged = n); (* Pre-build waves: single wave with all n entries *) - let remove_wave = ReactiveWave.create ~max_entries:n () in + let remove_wave = StableWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (stable_int i) Maybe.none_stable + StableWave.push remove_wave (stable_int i) Maybe.none_stable done; - let add_wave = ReactiveWave.create ~max_entries:n () in + let add_wave = StableWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push add_wave (stable_int i) + StableWave.push add_wave (stable_int i) (Maybe.to_stable (Maybe.some (Stable.int i))) done; @@ -455,8 +455,8 @@ let test_reactive_union_alloc_n n = emit_left add_wave done; assert (Reactive.length merged = n); - ReactiveWave.destroy remove_wave; - ReactiveWave.destroy add_wave; + StableWave.destroy remove_wave; + StableWave.destroy add_wave; Reactive.destroy_graph (); words_since () / iters @@ -488,13 +488,13 @@ let test_reactive_flatmap_alloc_n n = assert (Reactive.length derived = n); (* Pre-build waves *) - let remove_wave = ReactiveWave.create ~max_entries:n () in + let remove_wave = StableWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push remove_wave (stable_int i) Maybe.none_stable + StableWave.push remove_wave (stable_int i) Maybe.none_stable done; - let add_wave = ReactiveWave.create ~max_entries:n () in + let add_wave = StableWave.create ~max_entries:n () in for i = 0 to n - 1 do - ReactiveWave.push add_wave (stable_int i) + StableWave.push add_wave (stable_int i) (Maybe.to_stable (Maybe.some (Stable.int i))) done; @@ -514,8 +514,8 @@ let test_reactive_flatmap_alloc_n n = emit_src add_wave done; assert (Reactive.length derived = n); - ReactiveWave.destroy remove_wave; - ReactiveWave.destroy add_wave; + StableWave.destroy remove_wave; + StableWave.destroy add_wave; Reactive.destroy_graph (); words_since () / iters diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index 8f164092d30..2313c3d615c 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -18,7 +18,7 @@ let track_deltas c = let received = ref [] in c.subscribe (fun wave -> let rev_entries = ref [] in - ReactiveWave.iter wave (fun k mv -> + StableWave.iter wave (fun k mv -> let k = Stable.unsafe_to_value k in let mv = Stable.unsafe_to_value mv in rev_entries := (k, mv) :: !rev_entries); diff --git a/analysis/reactive/test/ReactiveTest.ml b/analysis/reactive/test/ReactiveTest.ml index 8f628e84ba8..388447b0f35 100644 --- a/analysis/reactive/test/ReactiveTest.ml +++ b/analysis/reactive/test/ReactiveTest.ml @@ -11,5 +11,4 @@ let () = IntegrationTest.run_all (); GlitchFreeTest.run_all (); AllocTest.run_all (); - TableTest.run_all (); Printf.printf "\nAll tests passed!\n" diff --git a/analysis/reactive/test/TableTest.ml b/analysis/reactive/test/TableTest.ml deleted file mode 100644 index 56f45bd8dc7..00000000000 --- a/analysis/reactive/test/TableTest.ml +++ /dev/null @@ -1,136 +0,0 @@ -(** Tests for stable ReactiveTable storage. *) - -let test_table_promoted_wave_lifecycle () = - Printf.printf "=== Test: table promoted-wave lifecycle ===\n"; - let iterations = 8 in - let count = 128 in - let width = 48 in - let initial_live_blocks = Allocator.live_block_count () in - let initial_live_block_slots = Allocator.live_block_capacity_slots () in - Gc.full_major (); - ignore (AllocMeasure.words_since ()); - let t = ReactiveTable.create ~initial_capacity:1 in - let create_words = AllocMeasure.words_since () in - assert (create_words = 0); - for iter = 1 to iterations do - ignore (AllocMeasure.words_since ()); - let fresh = - Array.init count (fun i -> - let c = Char.chr (((iter + i) mod 26) + Char.code 'a') in - let bytes = Bytes.make width c in - Bytes.set bytes 0 c; - Bytes.set bytes (width - 1) c; - bytes) - in - let produced_words = AllocMeasure.words_since () in - assert (produced_words > 0); - - for i = 0 to count - 1 do - assert (Allocator.is_in_minor_heap fresh.(i)) - done; - - Gc.full_major (); - - for i = 0 to count - 1 do - assert (not (Allocator.is_in_minor_heap fresh.(i))) - done; - - ignore (AllocMeasure.words_since ()); - ReactiveTable.clear t; - for i = 0 to count - 1 do - ReactiveTable.push t (Stable.of_value fresh.(i)) - done; - assert (ReactiveTable.length t = count); - assert (ReactiveTable.capacity t >= ReactiveTable.length t); - ReactiveTable.set t 0 (Stable.of_value fresh.(count - 1)); - assert (Stable.unsafe_to_value (ReactiveTable.get t 0) == fresh.(count - 1)); - for i = 0 to count - 1 do - let expected = if i = 0 then fresh.(count - 1) else fresh.(i) in - let recovered = Stable.unsafe_to_value (ReactiveTable.get t i) in - assert (recovered == expected); - assert (Bytes.get recovered 0 = Bytes.get expected 0); - assert (Bytes.get recovered (width - 1) = Bytes.get expected (width - 1)) - done; - assert (Stable.unsafe_to_value (ReactiveTable.pop t) == fresh.(count - 1)); - assert (ReactiveTable.length t = count - 1); - ReactiveTable.shrink_to_fit t; - assert (ReactiveTable.capacity t = ReactiveTable.length t); - ReactiveTable.clear t; - assert (ReactiveTable.length t = 0); - let table_words = AllocMeasure.words_since () in - Printf.printf " iter=%d produced=%d table_phase=%d\n" iter produced_words - table_words; - assert (table_words = 0); - - Gc.full_major () - done; - ignore (AllocMeasure.words_since ()); - ReactiveTable.destroy t; - let teardown_words = AllocMeasure.words_since () in - assert (teardown_words = 0); - assert (Allocator.live_block_count () = initial_live_blocks); - assert (Allocator.live_block_capacity_slots () = initial_live_block_slots); - Printf.printf " create=%d teardown=%d\n" create_words teardown_words; - Printf.printf "PASSED\n\n" - -let test_table_unsafe_minor_heap_demo () = - Printf.printf "=== Test: table unsafe minor-heap demo ===\n"; - match Sys.getenv_opt "RESCRIPT_REACTIVE_RUN_UNSAFE_TABLE_DEMO" with - | None -> - Printf.printf - "SKIPPED (set RESCRIPT_REACTIVE_RUN_UNSAFE_TABLE_DEMO=1 to run)\n\n" - | Some _ -> - let count = 2048 in - let width = 64 in - let t = ReactiveTable.create ~initial_capacity:count in - (* Each [Bytes.make] result starts in the minor heap. We store only the raw - addresses in stable storage and intentionally drop all OCaml roots. *) - for i = 0 to count - 1 do - let c = Char.chr ((i mod 26) + Char.code 'A') in - let fresh = Bytes.make width c in - Bytes.set fresh 0 c; - Bytes.set fresh (width - 1) c; - ReactiveTable.push t (Stable.unsafe_of_value fresh) - done; - Gc.compact (); - for round = 1 to 200 do - for j = 0 to 200 do - ignore (Bytes.make (1024 + ((round + j) mod 2048)) 'z') - done; - Gc.full_major (); - Gc.compact () - done; - Printf.printf - "About to validate %d minor-heap values stored in stable storage. This \ - is unsafe and may return garbage or crash.\n" - count; - let mismatches = ref 0 in - let samples = ref [] in - for i = 0 to count - 1 do - let expected = Char.chr ((i mod 26) + Char.code 'A') in - let recovered : bytes = Stable.unsafe_to_value (ReactiveTable.get t i) in - let ok = - Bytes.length recovered = width - && Bytes.get recovered 0 = expected - && Bytes.get recovered (width - 1) = expected - in - if not ok then ( - incr mismatches; - if List.length !samples < 8 then - let observed_len = try Bytes.length recovered with _ -> -1 in - let observed_first = try Bytes.get recovered 0 with _ -> '?' in - samples := - Printf.sprintf "slot=%d expected=%c len=%d first=%c" i expected - observed_len observed_first - :: !samples) - done; - Printf.printf "Observed mismatches: %d/%d\n" !mismatches count; - List.iter (fun s -> Printf.printf "%s\n" s) (List.rev !samples); - ReactiveTable.destroy t; - Printf.printf - "UNSAFE DEMO COMPLETED (result is not trustworthy; crash/corruption \ - would also be expected)\n\n" - -let run_all () = - test_table_promoted_wave_lifecycle (); - test_table_unsafe_minor_heap_demo () diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index c8e49d999ad..3a4caf96433 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -8,15 +8,15 @@ open Reactive 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) ReactiveWave.t = ReactiveWave.create () +let scratch_wave : (int, int) StableWave.t = StableWave.create () -let wave () : ('k, 'v) ReactiveWave.t = Obj.magic scratch_wave +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 - ReactiveWave.clear w; - ReactiveWave.push w (Stable.unsafe_of_value k) + StableWave.clear w; + StableWave.push w (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v)); emit w @@ -24,25 +24,25 @@ let emit_set emit k v = explicit stable-list type. *) let emit_edge_set emit k vs = let w = wave () in - ReactiveWave.clear w; - ReactiveWave.push w (Stable.unsafe_of_value k) + StableWave.clear w; + StableWave.push w (Stable.unsafe_of_value k) (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 - ReactiveWave.clear w; - ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable; + 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 - ReactiveWave.clear w; + StableWave.clear w; List.iter (fun (k, v) -> - ReactiveWave.push w (Stable.unsafe_of_value k) + StableWave.push w (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v))) entries; emit w @@ -50,28 +50,28 @@ let emit_sets emit entries = (** Emit a batch of (key, value option) entries — for mixed set/remove batches *) let emit_batch emit entries = let w = wave () in - ReactiveWave.clear w; + StableWave.clear w; List.iter (fun (k, v_opt) -> match v_opt with | Some v -> - ReactiveWave.push w (Stable.unsafe_of_value k) + StableWave.push w (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v)) - | None -> ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) + | None -> StableWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) entries; emit w (** Emit a batch of edge entries using the explicit stable-list type. *) let emit_edge_batch emit entries = let w = wave () in - ReactiveWave.clear w; + StableWave.clear w; List.iter (fun (k, vs_opt) -> match vs_opt with | Some vs -> - ReactiveWave.push w (Stable.unsafe_of_value k) + StableWave.push w (Stable.unsafe_of_value k) (Maybe.to_stable (Maybe.some (StableList.unsafe_of_list vs))) - | None -> ReactiveWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) + | None -> StableWave.push w (Stable.unsafe_of_value k) Maybe.none_stable) entries; emit w @@ -81,7 +81,7 @@ let emit_edge_batch emit entries = let subscribe handler t = t.subscribe (fun wave -> let rev_entries = ref [] in - ReactiveWave.iter wave (fun k mv -> + StableWave.iter wave (fun k mv -> let k = Stable.unsafe_to_value k in let mv = Stable.unsafe_to_value mv in rev_entries := (k, mv) :: !rev_entries); diff --git a/analysis/reactive/test/dune b/analysis/reactive/test/dune index 996fa5775c1..e7b34c15b93 100644 --- a/analysis/reactive/test/dune +++ b/analysis/reactive/test/dune @@ -12,6 +12,5 @@ IntegrationTest GlitchFreeTest AllocMeasure - AllocTest - TableTest) + AllocTest) (libraries reactive)) From 315d3b2777721b10d50cd484fa5ccd330c807250 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 19:19:49 +0100 Subject: [PATCH 40/54] analysis/reactive: rename unsafe_to_value to to_linear_value and document Stable policy MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit unsafe_to_value was misleading — reading from stable storage is not unsafe. The real contract is linear: consume the value immediately, don't stash it. Rename to to_linear_value and rewrite Stable.mli to clearly explain the two boundaries (storing and reading). Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Allocator.ml | 4 +- analysis/reactive/src/Reactive.ml | 14 +++--- analysis/reactive/src/Reactive.mli | 4 +- .../reactive/src/ReactiveFileCollection.ml | 6 +-- analysis/reactive/src/ReactiveFixpoint.ml | 47 +++++++++---------- analysis/reactive/src/ReactiveFlatMap.ml | 23 ++++----- analysis/reactive/src/ReactiveJoin.ml | 40 +++++++--------- analysis/reactive/src/ReactiveUnion.ml | 22 ++++----- analysis/reactive/src/Stable.ml | 2 +- analysis/reactive/src/Stable.mli | 29 +++++++++--- analysis/reactive/src/StableList.ml | 2 +- analysis/reactive/src/StableMap.ml | 2 +- analysis/reactive/src/StableMapMap.ml | 14 +++--- analysis/reactive/src/StableMapSet.ml | 18 +++---- analysis/reactive/src/StableSet.ml | 2 +- analysis/reactive/test/AllocTest.ml | 2 +- .../reactive/test/FixpointIncrementalTest.ml | 26 +++++----- analysis/reactive/test/GlitchFreeTest.ml | 4 +- analysis/reactive/test/IntegrationTest.ml | 16 +++---- analysis/reactive/test/TestHelpers.ml | 6 +-- 20 files changed, 143 insertions(+), 140 deletions(-) diff --git a/analysis/reactive/src/Allocator.ml b/analysis/reactive/src/Allocator.ml index 7e29a2d4010..4aabd10b2f9 100644 --- a/analysis/reactive/src/Allocator.ml +++ b/analysis/reactive/src/Allocator.ml @@ -87,9 +87,9 @@ module Block2 = struct 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.unsafe_to_value (Block.get t 0) + 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.unsafe_to_value (Block.get t 1) + 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 diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 30e28c3415a..c911311b694 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -480,15 +480,14 @@ module Source = struct } let apply_emit (tables : ('k, 'v) tables) k mv = - let mv = Stable.unsafe_to_value mv in + let mv = Stable.to_linear_value mv in if Maybe.is_some mv then ( let v = Maybe.unsafe_get mv in StableMap.replace tables.tbl k (Stable.unsafe_of_value v); StableMap.replace tables.pending k (Stable.unsafe_of_value (Maybe.some v))) else ( StableMap.remove tables.tbl k; - StableMap.replace tables.pending k - (Stable.unsafe_of_value Maybe.none)) + StableMap.replace tables.pending k (Stable.unsafe_of_value Maybe.none)) let create ~name () = let tbl : ('k, 'v) StableMap.t = StableMap.create () in @@ -509,7 +508,8 @@ module Source = struct StableWave.clear output_wave; StableMap.iter_with (fun wave k v -> - StableWave.push wave k (Stable.unsafe_of_value (Stable.unsafe_to_value v))) + StableWave.push wave k + (Stable.unsafe_of_value (Stable.to_linear_value v))) output_wave pending; StableMap.clear pending; notify_subscribers output_wave !subscribers) @@ -533,13 +533,15 @@ module Source = struct (fun f -> StableMap.iter_with (fun f k v -> - f k (Stable.unsafe_of_value (Stable.unsafe_to_value v))) + f k (Stable.unsafe_of_value (Stable.to_linear_value v))) f tbl); get = (fun k -> let mb = StableMap.find_maybe tbl k in if Maybe.is_some mb then - Maybe.some (Stable.unsafe_of_value (Stable.unsafe_to_value (Maybe.unsafe_get mb))) + Maybe.some + (Stable.unsafe_of_value + (Stable.to_linear_value (Maybe.unsafe_get mb))) else Maybe.none); length = (fun () -> StableMap.cardinal tbl); destroy; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index e3b9c0e4bad..cd5fd0455ca 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -97,9 +97,7 @@ val name : ('k, 'v) t -> string module Source : sig val create : - name:string -> - unit -> - ('k, 'v) t * (('k, 'v Maybe.t) StableWave.t -> unit) + 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 diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index a1937043e70..c4a7388f077 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -89,9 +89,7 @@ let process_files_batch t paths = let remove t path = Hashtbl.remove t.internal.cache path; StableWave.clear t.scratch_wave; - StableWave.push t.scratch_wave - (Stable.unsafe_of_value path) - Maybe.none_stable; + StableWave.push t.scratch_wave (Stable.unsafe_of_value path) Maybe.none_stable; t.emit t.scratch_wave (** Remove multiple files as a batch *) @@ -125,4 +123,4 @@ let mem t path = Hashtbl.mem t.internal.cache path let length t = Reactive.length t.collection let iter f t = t.collection.iter (fun k v -> - f (Stable.unsafe_to_value k) (Stable.unsafe_to_value v)) + f (Stable.to_linear_value k) (Stable.to_linear_value v)) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 4d19b5ffe24..6c737fb1b33 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -73,7 +73,7 @@ let compute_reachable ~visited t = let edge_work = ref 0 in StableSet.iter_with (fun (visited, frontier) k -> - bfs_seed_root visited frontier t (Stable.unsafe_to_value k) ()) + bfs_seed_root visited frontier t (Stable.to_linear_value k) ()) (visited, frontier) t.roots; while not (StableQueue.is_empty frontier) do let k = StableQueue.pop frontier in @@ -230,7 +230,7 @@ module Invariants = struct let copy_set_to_hashtbl (s : 'k StableSet.t) = let out = Hashtbl.create (StableSet.cardinal s) in StableSet.iter_with - (fun out k -> Hashtbl.replace out (Stable.unsafe_to_value k) ()) + (fun out k -> Hashtbl.replace out (Stable.to_linear_value k) ()) out s; out @@ -248,7 +248,7 @@ module Invariants = struct (* Drain and re-push to iterate without consuming *) let items = ref [] in while not (StableQueue.is_empty edge_change_queue) do - let src = Stable.unsafe_to_value (StableQueue.pop edge_change_queue) in + let src = Stable.to_linear_value (StableQueue.pop edge_change_queue) in items := src :: !items; enqueue q_copy src done; @@ -286,7 +286,7 @@ module Invariants = struct if enabled then StableSet.iter_with (fun () k -> - let k = Stable.unsafe_to_value k in + let k = Stable.to_linear_value k in assert_ (StableSet.mem current (stable_key k)) "ReactiveFixpoint.apply invariant failed: deleted node not in \ @@ -305,7 +305,7 @@ module Invariants = struct if enabled then StableSet.iter_with (fun () k -> - let k = Stable.unsafe_to_value k in + let k = Stable.to_linear_value k in if not (StableSet.mem current (stable_key k)) then assert_ (not (supported k)) @@ -317,7 +317,7 @@ module Invariants = struct if enabled then ( let expected = Hashtbl.copy pre_current in StableSet.iter_with - (fun expected k -> Hashtbl.remove expected (Stable.unsafe_to_value k)) + (fun expected k -> Hashtbl.remove expected (Stable.to_linear_value k)) expected deleted_nodes; let current_ht = copy_set_to_hashtbl current in assert_ @@ -330,7 +330,7 @@ module Invariants = struct let expected = Hashtbl.create (StableSet.cardinal deleted_nodes) in StableSet.iter_with (fun expected k -> - let k = Stable.unsafe_to_value k in + let k = Stable.to_linear_value k in if not (StableSet.mem current (stable_key k)) then Hashtbl.replace expected k ()) expected deleted_nodes; @@ -357,7 +357,7 @@ module Invariants = struct let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in StableSet.iter_with (fun expected_adds k -> - let k = Stable.unsafe_to_value k in + let k = Stable.to_linear_value k in if not (Hashtbl.mem pre_current k) then Hashtbl.replace expected_adds k ()) expected_adds t.current; @@ -477,8 +477,7 @@ let remove_pred t ~target ~pred = 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 (stable_key k) t - has_live_pred_key + StableMapSet.exists_inner_with t.pred_map (stable_key k) t has_live_pred_key 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 @@ -526,7 +525,7 @@ let initialize t ~roots ~edges = 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:(Stable.unsafe_to_value k) + apply_edge_update t ~src:(Stable.to_linear_value k) ~new_successors:successors); recompute_current t @@ -653,20 +652,20 @@ let apply_list t ~roots ~edges = buffer added roots for later expansion *) StableWave.iter_with roots (fun t k mv -> - scan_root_entry t (Stable.unsafe_to_value k) (Stable.unsafe_to_value mv)) + scan_root_entry t (Stable.to_linear_value 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 -> - let mv = Stable.unsafe_to_value mv in + let mv = Stable.to_linear_value mv in let mv = if Maybe.is_some mv then Maybe.some (Stable.unsafe_of_value (Maybe.unsafe_get mv)) else Maybe.none in - scan_edge_entry t (Stable.unsafe_to_value src) mv) + scan_edge_entry t (Stable.to_linear_value src) mv) t; Invariants.assert_edge_has_new_consistent @@ -677,7 +676,7 @@ let apply_list t ~roots ~edges = (* Phase 2: delete BFS *) while not (StableQueue.is_empty t.delete_queue) do - let k = Stable.unsafe_to_value (StableQueue.pop t.delete_queue) in + let k = Stable.to_linear_value (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; @@ -691,8 +690,8 @@ let apply_list t ~roots ~edges = (* Phase 3: apply root and edge mutations *) StableWave.iter_with roots (fun t k mv -> - apply_root_mutation t (Stable.unsafe_to_value k) - (Stable.unsafe_to_value mv)) + apply_root_mutation t (Stable.to_linear_value k) + (Stable.to_linear_value mv)) t; (* Apply edge updates by draining edge_change_queue. *) @@ -703,7 +702,7 @@ let apply_list t ~roots ~edges = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in apply_edge_update t - ~src:(Stable.unsafe_to_value src) + ~src:(Stable.to_linear_value src) ~new_successors:new_succs done; (* Rebuild edge_change_queue from new_successors_for_changed keys for @@ -722,7 +721,7 @@ let apply_list t ~roots ~edges = StableSet.clear t.rederive_pending; StableSet.iter_with - (fun t k -> enqueue_rederive_if_needed_kv t (Stable.unsafe_to_value k)) + (fun t k -> enqueue_rederive_if_needed_kv t (Stable.to_linear_value k)) t t.deleted_nodes; while not (StableQueue.is_empty t.rederive_queue) do @@ -732,7 +731,7 @@ let apply_list t ~roots ~edges = if StableSet.mem t.deleted_nodes k && (not (StableSet.mem t.current k)) - && is_supported t (Stable.unsafe_to_value k) + && is_supported t (Stable.to_linear_value k) then ( StableSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; @@ -754,14 +753,14 @@ let apply_list t ~roots ~edges = (* Seed expansion from added roots *) while not (StableQueue.is_empty t.added_roots_queue) do - add_live t (Stable.unsafe_to_value (StableQueue.pop t.added_roots_queue)) + add_live t (Stable.to_linear_value (StableQueue.pop t.added_roots_queue)) done; (* 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 (Stable.unsafe_to_value src) + enqueue_expand t (Stable.to_linear_value src) done; while not (StableQueue.is_empty t.expansion_queue) do @@ -776,14 +775,14 @@ let apply_list t ~roots ~edges = StableList.iter_with add_live t succs) done; StableSet.iter_with - (fun t k -> emit_removal t (Stable.unsafe_to_value k) ()) + (fun t k -> emit_removal t (Stable.to_linear_value k) ()) t t.deleted_nodes; let output_entries_list = if Invariants.enabled then ( let entries = ref [] in StableWave.iter t.output_wave (fun k v_opt -> entries := - (Stable.unsafe_to_value k, Stable.unsafe_to_value v_opt) :: !entries); + (Stable.to_linear_value k, Stable.to_linear_value v_opt) :: !entries); !entries) else [] in diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 4b998491eee..af4299ec0d1 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -109,18 +109,15 @@ let remove_source (t : (_, _, _, _) t) k1 = (* Merge callback for recompute_target iter_with *) let merge_one_contribution (t : (_, _, _, _) t) _k1 v = - let v = Stable.unsafe_to_value v in + let v = Stable.to_linear_value v in if t.merge_first then ( t.merge_acc <- v; t.merge_first <- false) else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _) t) k2 = - let k2 = Stable.unsafe_to_value k2 in - if - StableMapMap.inner_cardinal t.contributions - (Stable.unsafe_of_value k2) - > 0 + let k2 = Stable.to_linear_value k2 in + if StableMapMap.inner_cardinal t.contributions (Stable.unsafe_of_value k2) > 0 then ( t.merge_first <- true; StableMapMap.iter_inner_with t.contributions @@ -134,14 +131,12 @@ let recompute_target (t : (_, _, _, _) t) k2 = (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( StableMap.remove t.target (Stable.unsafe_of_value k2); - StableWave.push t.output_wave - (Stable.unsafe_of_value k2) - Maybe.none_stable) + StableWave.push t.output_wave (Stable.unsafe_of_value k2) Maybe.none_stable) (* Single-pass process + count for scratch *) let process_scratch_entry (t : (_, _, _, _) t) k1 mv = - let k1 = Stable.unsafe_to_value k1 in - let mv = Stable.unsafe_to_value mv in + let k1 = Stable.to_linear_value k1 in + let mv = Stable.to_linear_value mv in t.result.entries_received <- t.result.entries_received + 1; remove_source t k1; if Maybe.is_some mv then ( @@ -152,7 +147,7 @@ let process_scratch_entry (t : (_, _, _, _) t) k1 mv = else t.result.removes_received <- t.result.removes_received + 1 let count_output_entry (r : process_result) _k mv = - let mv = Stable.unsafe_to_value mv in + let mv = Stable.to_linear_value mv in if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 @@ -179,8 +174,8 @@ let process (t : (_, _, _, _) t) = r let init_entry (t : (_, _, _, _) t) k1 v1 = - let k1 = Stable.unsafe_to_value k1 in - let v1 = Stable.unsafe_to_value v1 in + let k1 = Stable.to_linear_value k1 in + let v1 = Stable.to_linear_value v1 in t.current_k1 <- k1; t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 732fa91e498..1b5cc10e152 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -130,10 +130,9 @@ let unlink_right_key (t : (_, _, _, _, _, _) t) k1 = StableMap.find_maybe t.left_to_right_key (Stable.unsafe_of_value k1) in if Maybe.is_some mb then ( - let old_k2 = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + let old_k2 = Stable.to_linear_value (Maybe.unsafe_get mb) in StableMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); - StableMapSet.remove_from_set_and_recycle_if_empty - t.right_key_to_left_keys + StableMapSet.remove_from_set_and_recycle_if_empty t.right_key_to_left_keys (Stable.unsafe_of_value old_k2) (Stable.unsafe_of_value k1)) @@ -148,7 +147,7 @@ let process_left_entry (t : (_, _, _, _, _, _) t) k1 v1 = (Stable.unsafe_of_value k2) (Stable.unsafe_of_value k1); let right_val = - Stable.unsafe_to_value + Stable.to_linear_value (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) in t.current_k1 <- k1; @@ -161,18 +160,15 @@ let remove_left_entry (t : (_, _, _, _, _, _) t) k1 = (* Merge callback for recompute_target iter_with *) let merge_one_contribution (t : (_, _, _, _, _, _) t) _k1 v = - let v = Stable.unsafe_to_value v in + let v = Stable.to_linear_value v in if t.merge_first then ( t.merge_acc <- v; t.merge_first <- false) else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _, _, _) t) k3 = - let k3 = Stable.unsafe_to_value k3 in - if - StableMapMap.inner_cardinal t.contributions - (Stable.unsafe_of_value k3) - > 0 + let k3 = Stable.to_linear_value k3 in + if StableMapMap.inner_cardinal t.contributions (Stable.unsafe_of_value k3) > 0 then ( t.merge_first <- true; StableMapMap.iter_inner_with t.contributions @@ -186,14 +182,12 @@ let recompute_target (t : (_, _, _, _, _, _) t) k3 = (Stable.unsafe_of_value (Maybe.some t.merge_acc))) else ( StableMap.remove t.target (Stable.unsafe_of_value k3); - StableWave.push t.output_wave - (Stable.unsafe_of_value k3) - Maybe.none_stable) + StableWave.push t.output_wave (Stable.unsafe_of_value k3) Maybe.none_stable) (* Single-pass process + count for left scratch *) let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = - let k1 = Stable.unsafe_to_value k1 in - let mv = Stable.unsafe_to_value mv in + let k1 = Stable.to_linear_value k1 in + let mv = Stable.to_linear_value 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; @@ -208,15 +202,15 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = - let k1 = Stable.unsafe_to_value k1 in + let k1 = Stable.to_linear_value k1 in let mb = StableMap.find_maybe t.left_entries (Stable.unsafe_of_value k1) in if Maybe.is_some mb then - process_left_entry t k1 (Stable.unsafe_to_value (Maybe.unsafe_get mb)) + process_left_entry t k1 (Stable.to_linear_value (Maybe.unsafe_get mb)) (* Single-pass process + count for right scratch *) let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = - let k2 = Stable.unsafe_to_value k2 in - let _mv = Stable.unsafe_to_value _mv in + let k2 = Stable.to_linear_value k2 in + let _mv = Stable.to_linear_value _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; @@ -225,7 +219,7 @@ let process_right_scratch_entry (t : (_, _, _, _, _, _) t) k2 _mv = t reprocess_left_entry let count_output_entry (r : process_result) _k mv = - let mv = Stable.unsafe_to_value mv in + let mv = Stable.to_linear_value mv in if Maybe.is_some mv then r.adds_emitted <- r.adds_emitted + 1 else r.removes_emitted <- r.removes_emitted + 1 @@ -255,8 +249,8 @@ let process (t : (_, _, _, _, _, _) t) = r let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = - let k1 = Stable.unsafe_to_value k1 in - let v1 = Stable.unsafe_to_value v1 in + let k1 = Stable.to_linear_value k1 in + let v1 = Stable.to_linear_value v1 in StableMap.replace t.left_entries (Stable.unsafe_of_value k1) (Stable.unsafe_of_value v1); @@ -268,7 +262,7 @@ let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = (Stable.unsafe_of_value k2) (Stable.unsafe_of_value k1); let right_val = - Stable.unsafe_to_value + Stable.to_linear_value (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) in t.current_k1 <- k1; diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index c81d610e88c..669588690e7 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -60,8 +60,8 @@ 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 k = Stable.unsafe_to_value k in - let mv = Stable.unsafe_to_value mv in + let k = Stable.to_linear_value k in + let mv = Stable.to_linear_value mv in let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( @@ -74,8 +74,8 @@ let apply_left_entry t k mv = StableSet.add t.affected (Stable.unsafe_of_value k) let apply_right_entry t k mv = - let k = Stable.unsafe_to_value k in - let mv = Stable.unsafe_to_value mv in + let k = Stable.to_linear_value k in + let mv = Stable.to_linear_value mv in let r = t.result in r.entries_received <- r.entries_received + 1; if Maybe.is_some mv then ( @@ -88,7 +88,7 @@ let apply_right_entry t k mv = StableSet.add t.affected (Stable.unsafe_of_value k) let recompute_affected_entry t k = - let k = Stable.unsafe_to_value k in + let k = Stable.to_linear_value k in let r = t.result in let lv = StableMap.find_maybe t.left_values (Stable.unsafe_of_value k) in let rv = StableMap.find_maybe t.right_values (Stable.unsafe_of_value k) in @@ -98,21 +98,21 @@ let recompute_affected_entry t k = if has_right then ( let merged = t.merge - (Stable.unsafe_to_value (Maybe.unsafe_get lv)) - (Stable.unsafe_to_value (Maybe.unsafe_get rv)) + (Stable.to_linear_value (Maybe.unsafe_get lv)) + (Stable.to_linear_value (Maybe.unsafe_get rv)) in StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value merged); StableWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some merged))) else - let v = Stable.unsafe_to_value (Maybe.unsafe_get lv) in + let v = Stable.to_linear_value (Maybe.unsafe_get lv) in StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); StableWave.push t.output_wave (Stable.unsafe_of_value k) (Stable.unsafe_of_value (Maybe.some v))) else if has_right then ( - let v = Stable.unsafe_to_value (Maybe.unsafe_get rv) in + let v = Stable.to_linear_value (Maybe.unsafe_get rv) in StableMap.replace t.target (Stable.unsafe_of_value k) (Stable.unsafe_of_value v); StableWave.push t.output_wave (Stable.unsafe_of_value k) @@ -157,8 +157,8 @@ let init_right t k v = if Maybe.is_some lv then Stable.unsafe_of_value (t.merge - (Stable.unsafe_to_value (Maybe.unsafe_get lv)) - (Stable.unsafe_to_value v)) + (Stable.to_linear_value (Maybe.unsafe_get lv)) + (Stable.to_linear_value v)) else v in StableMap.replace t.target k merged diff --git a/analysis/reactive/src/Stable.ml b/analysis/reactive/src/Stable.ml index 5286c6cda0a..b7579e8d8b0 100644 --- a/analysis/reactive/src/Stable.ml +++ b/analysis/reactive/src/Stable.ml @@ -4,7 +4,7 @@ external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" [@@noalloc] let unsafe_of_value x = x -let unsafe_to_value x = x +let to_linear_value x = x let int x = unsafe_of_value x let unit = unsafe_of_value () diff --git a/analysis/reactive/src/Stable.mli b/analysis/reactive/src/Stable.mli index 668f9f69386..1e11c3b93fb 100644 --- a/analysis/reactive/src/Stable.mli +++ b/analysis/reactive/src/Stable.mli @@ -1,13 +1,28 @@ -(** Values marked for storage in stable containers. +(** Values marked for storage in stable (C-allocated) containers. - This type does not prove safety. It marks values that are crossing the - stable boundary so call sites can be audited explicitly. *) + 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. *) type 'a t val unsafe_of_value : 'a -> 'a t (** Unsafely mark a value as suitable for stable storage. The caller must - ensure the stable invariants hold. *) + 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. @@ -21,5 +36,7 @@ val int : int -> int t val unit : unit t (** [()] as a stable value. *) -val unsafe_to_value : 'a t -> 'a -(** Unsafely recover a regular OCaml value from a stable-marked 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. *) diff --git a/analysis/reactive/src/StableList.ml b/analysis/reactive/src/StableList.ml index f24ed83de9e..7c5212cba45 100644 --- a/analysis/reactive/src/StableList.ml +++ b/analysis/reactive/src/StableList.ml @@ -4,7 +4,7 @@ type 'a t = 'a inner Stable.t let unsafe_of_list = Stable.unsafe_of_value let unsafe_inner_of_list (l : 'a list) : 'a inner = l let of_list = Stable.of_value -let list_of = Stable.unsafe_to_value +let list_of = Stable.to_linear_value let of_stable_list xs = xs let empty () : 'a t = Stable.of_value [] diff --git a/analysis/reactive/src/StableMap.ml b/analysis/reactive/src/StableMap.ml index 1a1653bc19b..96d908b67ef 100644 --- a/analysis/reactive/src/StableMap.ml +++ b/analysis/reactive/src/StableMap.ml @@ -31,7 +31,7 @@ let[@inline] get_val t j : 'v Stable.t = 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.unsafe_to_value x) land mask t +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 diff --git a/analysis/reactive/src/StableMapMap.ml b/analysis/reactive/src/StableMapMap.ml index 568fa553047..ad118a8894c 100644 --- a/analysis/reactive/src/StableMapMap.ml +++ b/analysis/reactive/src/StableMapMap.ml @@ -9,13 +9,13 @@ let create () = StableMap.create () let destroy t = StableMap.iter_with - (fun () _ko inner -> StableMap.destroy (Stable.unsafe_to_value inner)) + (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.unsafe_to_value (Maybe.unsafe_get m) + 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); @@ -28,7 +28,7 @@ let replace t ko 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.unsafe_to_value (Maybe.unsafe_get mb) in + 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; @@ -37,7 +37,7 @@ let remove_from_inner_and_recycle_if_empty t ko ki = let drain_outer t ko ctx f = let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then ( - let inner = Stable.unsafe_to_value (Maybe.unsafe_get mb) in + let inner = Stable.to_linear_value (Maybe.unsafe_get mb) in StableMap.iter_with f ctx inner; StableMap.remove t ko; StableMap.destroy inner) @@ -45,19 +45,19 @@ let drain_outer t ko ctx f = let find_inner_maybe t ko = let mb = StableMap.find_maybe t ko in if Maybe.is_some mb then - Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) + 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.unsafe_to_value (Maybe.unsafe_get mb) in + 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.unsafe_to_value (Maybe.unsafe_get mb)) + StableMap.cardinal (Stable.to_linear_value (Maybe.unsafe_get mb)) else 0 let outer_cardinal t = StableMap.cardinal t diff --git a/analysis/reactive/src/StableMapSet.ml b/analysis/reactive/src/StableMapSet.ml index b320e2a3404..b994b189127 100644 --- a/analysis/reactive/src/StableMapSet.ml +++ b/analysis/reactive/src/StableMapSet.ml @@ -9,15 +9,15 @@ let create () = StableMap.create () let destroy t = StableMap.iter_with - (fun () _k set -> StableSet.destroy (Stable.unsafe_to_value set)) + (fun () _k set -> StableSet.destroy (Stable.to_linear_value set)) () t; StableMap.destroy t -let destroy_inner_set () _k set = StableSet.destroy (Stable.unsafe_to_value set) +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.unsafe_to_value (Maybe.unsafe_get m) + 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); @@ -30,7 +30,7 @@ let add t k 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.unsafe_to_value (Maybe.unsafe_get mb) in + let set = Stable.to_linear_value (Maybe.unsafe_get mb) in StableSet.iter_with f ctx set; StableMap.remove t k; StableSet.destroy set) @@ -38,7 +38,7 @@ let drain_key t k ctx f = 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.unsafe_to_value (Maybe.unsafe_get mb) in + 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; @@ -47,26 +47,26 @@ let remove_from_set_and_recycle_if_empty t k v = let find_inner_maybe t k = let mb = StableMap.find_maybe t k in if Maybe.is_some mb then - Maybe.some (Stable.unsafe_to_value (Maybe.unsafe_get mb)) + 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.unsafe_to_value (Maybe.unsafe_get mb) in + 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.unsafe_to_value (Maybe.unsafe_get mb) in + 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.unsafe_to_value stable_set)) + f ctx stable_k (Stable.to_linear_value stable_set)) ctx t let clear t = diff --git a/analysis/reactive/src/StableSet.ml b/analysis/reactive/src/StableSet.ml index 5898b541f5d..2c1cc76688b 100644 --- a/analysis/reactive/src/StableSet.ml +++ b/analysis/reactive/src/StableSet.ml @@ -29,7 +29,7 @@ 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.unsafe_to_value x) land mask t +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 diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 91d297e20e4..c0c6a32af15 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -219,7 +219,7 @@ let test_join_alloc_n n = if Maybe.is_some mb then Maybe.some (Stable.unsafe_of_value - (Stable.unsafe_to_value (Maybe.unsafe_get mb))) + (Stable.to_linear_value (Maybe.unsafe_get mb))) else Maybe.none) in diff --git a/analysis/reactive/test/FixpointIncrementalTest.ml b/analysis/reactive/test/FixpointIncrementalTest.ml index d8f97d70fe3..7a3e8578ae1 100644 --- a/analysis/reactive/test/FixpointIncrementalTest.ml +++ b/analysis/reactive/test/FixpointIncrementalTest.ml @@ -294,7 +294,7 @@ let test_fixpoint_remove_spurious_root () = emit_set emit_init "b" (); Printf.printf "After spurious root b: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (get_opt fp "b" = Some ()); @@ -302,14 +302,14 @@ let test_fixpoint_remove_spurious_root () = emit_set emit_init "root" (); Printf.printf "After true root: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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_edge_set emit_edges "root" ["a"]; Printf.printf "After edge root->a: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value k :: !items) fp; + iter (fun k _ -> items := Stable.to_linear_value k :: !items) fp; String.concat ", " (List.sort String.compare !items)); assert (get_opt fp "a" = Some ()); @@ -317,7 +317,7 @@ let test_fixpoint_remove_spurious_root () = emit_edge_set emit_edges "a" ["b"]; Printf.printf "After edge a->b: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -330,7 +330,7 @@ let test_fixpoint_remove_spurious_root () = Printf.printf "After removing b from init: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -372,7 +372,7 @@ let test_fixpoint_remove_edge_entry_alternative_source () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -384,7 +384,7 @@ let test_fixpoint_remove_edge_entry_alternative_source () = Printf.printf "After remove edge entry 'a': fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -426,7 +426,7 @@ let test_fixpoint_remove_edge_rederivation () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -439,7 +439,7 @@ let test_fixpoint_remove_edge_rederivation () = Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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) @@ -481,7 +481,7 @@ let test_fixpoint_remove_edge_entry_rederivation () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -493,7 +493,7 @@ let test_fixpoint_remove_edge_entry_rederivation () = Printf.printf "After remove 'a' entry: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -535,7 +535,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = Printf.printf "Initial: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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); @@ -549,7 +549,7 @@ let test_fixpoint_remove_edge_entry_higher_rank_support () = Printf.printf "After removing a->c: fp=[%s]\n" (let items = ref [] in - iter (fun k _ -> items := Stable.unsafe_to_value 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) diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index 2313c3d615c..49b7d22d3fe 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -19,8 +19,8 @@ let track_deltas c = c.subscribe (fun wave -> let rev_entries = ref [] in StableWave.iter wave (fun k mv -> - let k = Stable.unsafe_to_value k in - let mv = Stable.unsafe_to_value mv in + 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 diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/IntegrationTest.ml index 68d92f3cedc..42be1c387f1 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -43,16 +43,16 @@ let test_file_collection () = iter (fun word count -> Printf.printf " %s: %d\n" - (Stable.unsafe_to_value word) - (Stable.unsafe_to_value count)) + (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" - (Stable.unsafe_to_value word) - (Stable.unsafe_to_value count)) + (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 *) @@ -76,16 +76,16 @@ let test_file_collection () = iter (fun word count -> Printf.printf " %s: %d\n" - (Stable.unsafe_to_value word) - (Stable.unsafe_to_value count)) + (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" - (Stable.unsafe_to_value word) - (Stable.unsafe_to_value count)) + (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 *) diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index 3a4caf96433..e6ee896da6c 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -82,8 +82,8 @@ let subscribe handler t = t.subscribe (fun wave -> let rev_entries = ref [] in StableWave.iter wave (fun k mv -> - let k = Stable.unsafe_to_value k in - let mv = Stable.unsafe_to_value mv in + 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)) @@ -126,7 +126,7 @@ let[@warning "-32"] write_lines path lines = 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.unsafe_to_value v) + | Some v -> Some (Stable.to_linear_value v) | None -> None (** {1 Common set modules} *) From 630a876bc53cab4c543b3e6385140b7d75304481 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 20:11:54 +0100 Subject: [PATCH 41/54] analysis/reactive: make Reactive.ml and ReactiveUnion.ml stable-safe Eliminate all Stable.unsafe_of_value calls from inner modules by threading Stable.t types through APIs. Push the boundary to reanalyze callers. Key changes: - ReactiveUnion: merge signature takes 'v Stable.t -> 'v Stable.t -> 'v Stable.t - Reactive.ml: remove pointless round-trips in Source (iter, get, pending->wave), rewrite apply_emit with Maybe.of_stable/to_stable - Add Stable.unsafe_to_nonlinear_value for auditable non-linear reads - Update all reanalyze callers to wrap/unwrap at the boundary - Add STABLE_SAFETY.md guide documenting patterns and current status Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/STABLE_SAFETY.md | 213 ++++++++++++++++++ analysis/reactive/src/Reactive.ml | 29 +-- analysis/reactive/src/Reactive.mli | 4 +- analysis/reactive/src/ReactiveUnion.ml | 66 ++---- analysis/reactive/src/ReactiveUnion.mli | 2 +- analysis/reactive/src/Stable.ml | 1 + analysis/reactive/src/Stable.mli | 14 +- analysis/reactive/test/UnionTest.ml | 13 +- analysis/reanalyze/src/AnnotationStore.ml | 13 +- analysis/reanalyze/src/CrossFileItemsStore.ml | 8 +- analysis/reanalyze/src/DeadCommon.ml | 12 +- analysis/reanalyze/src/DeclarationStore.ml | 23 +- .../reanalyze/src/ReactiveExceptionRefs.ml | 6 +- analysis/reanalyze/src/ReactiveLiveness.ml | 21 +- analysis/reanalyze/src/ReactiveLiveness.mli | 2 +- analysis/reanalyze/src/ReactiveMerge.ml | 39 +++- analysis/reanalyze/src/ReactiveSolver.ml | 30 ++- analysis/reanalyze/src/ReactiveTypeDeps.ml | 22 +- analysis/reanalyze/src/Reanalyze.ml | 9 +- 19 files changed, 407 insertions(+), 120 deletions(-) create mode 100644 analysis/reactive/STABLE_SAFETY.md diff --git a/analysis/reactive/STABLE_SAFETY.md b/analysis/reactive/STABLE_SAFETY.md new file mode 100644 index 00000000000..fa4a5fb451d --- /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/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index c911311b694..13b4a8803f7 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -480,14 +480,13 @@ module Source = struct } let apply_emit (tables : ('k, 'v) tables) k mv = - let mv = Stable.to_linear_value mv in + let mv = Maybe.of_stable mv in if Maybe.is_some mv then ( - let v = Maybe.unsafe_get mv in - StableMap.replace tables.tbl k (Stable.unsafe_of_value v); - StableMap.replace tables.pending k (Stable.unsafe_of_value (Maybe.some v))) + 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 (Stable.unsafe_of_value Maybe.none)) + StableMap.replace tables.pending k (Maybe.to_stable mv)) let create ~name () = let tbl : ('k, 'v) StableMap.t = StableMap.create () in @@ -507,9 +506,7 @@ module Source = struct my_stats.entries_emitted <- my_stats.entries_emitted + count; StableWave.clear output_wave; StableMap.iter_with - (fun wave k v -> - StableWave.push wave k - (Stable.unsafe_of_value (Stable.to_linear_value v))) + (fun wave k v -> StableWave.push wave k v) output_wave pending; StableMap.clear pending; notify_subscribers output_wave !subscribers) @@ -529,20 +526,8 @@ module Source = struct { name; subscribe = (fun h -> subscribers := h :: !subscribers); - iter = - (fun f -> - StableMap.iter_with - (fun f k v -> - f k (Stable.unsafe_of_value (Stable.to_linear_value v))) - f tbl); - get = - (fun k -> - let mb = StableMap.find_maybe 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); + iter = (fun f -> StableMap.iter f tbl); + get = (fun k -> StableMap.find_maybe tbl k); length = (fun () -> StableMap.cardinal tbl); destroy; stats = my_stats; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index cd5fd0455ca..011eb61863c 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -139,11 +139,11 @@ module Union : sig name:string -> ('k, 'v) t -> ('k, 'v) t -> - ?merge:('v -> 'v -> 'v) -> + ?merge:('v Stable.t -> 'v Stable.t -> 'v Stable.t) -> unit -> ('k, 'v) t (** Combine two collections. - Optional merge function combines values for the same key. + Optional merge function combines stable-marked values for the same key. Separate left/right pending buffers ensure glitch-freedom. *) end diff --git a/analysis/reactive/src/ReactiveUnion.ml b/analysis/reactive/src/ReactiveUnion.ml index 669588690e7..539a9c2600b 100644 --- a/analysis/reactive/src/ReactiveUnion.ml +++ b/analysis/reactive/src/ReactiveUnion.ml @@ -1,7 +1,7 @@ (** Zero-allocation union state and processing logic. *) type ('k, 'v) t = { - merge: 'v -> 'v -> 'v; + 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; @@ -60,66 +60,51 @@ 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 k = Stable.to_linear_value k in - let mv = Stable.to_linear_value mv in + 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 (Stable.unsafe_of_value k) - (Stable.unsafe_of_value (Maybe.unsafe_get mv)); + StableMap.replace t.left_values k (Maybe.unsafe_get mv); r.adds_received <- r.adds_received + 1) else ( - StableMap.remove t.left_values (Stable.unsafe_of_value k); + StableMap.remove t.left_values k; r.removes_received <- r.removes_received + 1); - StableSet.add t.affected (Stable.unsafe_of_value k) + StableSet.add t.affected k let apply_right_entry t k mv = - let k = Stable.to_linear_value k in - let mv = Stable.to_linear_value mv in + 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 (Stable.unsafe_of_value k) - (Stable.unsafe_of_value (Maybe.unsafe_get mv)); + StableMap.replace t.right_values k (Maybe.unsafe_get mv); r.adds_received <- r.adds_received + 1) else ( - StableMap.remove t.right_values (Stable.unsafe_of_value k); + StableMap.remove t.right_values k; r.removes_received <- r.removes_received + 1); - StableSet.add t.affected (Stable.unsafe_of_value k) + StableSet.add t.affected k let recompute_affected_entry t k = - let k = Stable.to_linear_value k in let r = t.result in - let lv = StableMap.find_maybe t.left_values (Stable.unsafe_of_value k) in - let rv = StableMap.find_maybe t.right_values (Stable.unsafe_of_value k) 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 - (Stable.to_linear_value (Maybe.unsafe_get lv)) - (Stable.to_linear_value (Maybe.unsafe_get rv)) - in - StableMap.replace t.target (Stable.unsafe_of_value k) - (Stable.unsafe_of_value merged); - StableWave.push t.output_wave (Stable.unsafe_of_value k) - (Stable.unsafe_of_value (Maybe.some merged))) + 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 = Stable.to_linear_value (Maybe.unsafe_get lv) in - StableMap.replace t.target (Stable.unsafe_of_value k) - (Stable.unsafe_of_value v); - StableWave.push t.output_wave (Stable.unsafe_of_value k) - (Stable.unsafe_of_value (Maybe.some v))) + 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 = Stable.to_linear_value (Maybe.unsafe_get rv) in - StableMap.replace t.target (Stable.unsafe_of_value k) - (Stable.unsafe_of_value v); - StableWave.push t.output_wave (Stable.unsafe_of_value k) - (Stable.unsafe_of_value (Maybe.some v))) + 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 (Stable.unsafe_of_value k); - StableWave.push t.output_wave (Stable.unsafe_of_value k) Maybe.none_stable); + 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 @@ -154,12 +139,7 @@ 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 - Stable.unsafe_of_value - (t.merge - (Stable.to_linear_value (Maybe.unsafe_get lv)) - (Stable.to_linear_value v)) - else v + if Maybe.is_some lv then t.merge (Maybe.unsafe_get lv) v else v in StableMap.replace t.target k merged diff --git a/analysis/reactive/src/ReactiveUnion.mli b/analysis/reactive/src/ReactiveUnion.mli index f4fe1a25742..131c4db6c26 100644 --- a/analysis/reactive/src/ReactiveUnion.mli +++ b/analysis/reactive/src/ReactiveUnion.mli @@ -13,7 +13,7 @@ type process_result = { mutable removes_emitted: int; } -val create : merge:('v -> 'v -> 'v) -> ('k, 'v) t +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 diff --git a/analysis/reactive/src/Stable.ml b/analysis/reactive/src/Stable.ml index b7579e8d8b0..d9316e81fd3 100644 --- a/analysis/reactive/src/Stable.ml +++ b/analysis/reactive/src/Stable.ml @@ -5,6 +5,7 @@ external is_in_minor_heap : 'a -> bool = "caml_reactive_value_is_young" 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 () diff --git a/analysis/reactive/src/Stable.mli b/analysis/reactive/src/Stable.mli index 1e11c3b93fb..991260eab3a 100644 --- a/analysis/reactive/src/Stable.mli +++ b/analysis/reactive/src/Stable.mli @@ -15,7 +15,12 @@ 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. *) + 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 @@ -40,3 +45,10 @@ 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/test/UnionTest.ml b/analysis/reactive/test/UnionTest.ml index 5bd2f193055..616b36bdb11 100644 --- a/analysis/reactive/test/UnionTest.ml +++ b/analysis/reactive/test/UnionTest.ml @@ -70,7 +70,11 @@ let test_union_with_merge () = (* Create union with set union as merge *) let combined = - Union.create ~name:"combined" left right ~merge:IntSet.union () + 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} *) @@ -143,7 +147,12 @@ let test_union_existing_data_with_non_idempotent_merge () = (* 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:( + ) () in + 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); diff --git a/analysis/reanalyze/src/AnnotationStore.ml b/analysis/reanalyze/src/AnnotationStore.ml index f9925a65a0a..95e1fa1758b 100644 --- a/analysis/reanalyze/src/AnnotationStore.ml +++ b/analysis/reanalyze/src/AnnotationStore.ml @@ -16,25 +16,26 @@ let is_annotated_dead t pos = match t with | Frozen ann -> FileAnnotations.is_annotated_dead ann pos | Reactive reactive -> - let mb = Reactive.get reactive pos in - Maybe.is_some mb && Maybe.unsafe_get mb = FileAnnotations.Dead + 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 -> - let mb = Reactive.get reactive pos in + let mb = Reactive.get reactive (Stable.unsafe_of_value pos) in Maybe.is_some mb && - let v = Maybe.unsafe_get mb in + 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 -> - let mb = Reactive.get reactive pos in + let mb = Reactive.get reactive (Stable.unsafe_of_value pos) in Maybe.is_some mb && - let v = Maybe.unsafe_get mb in + 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 33e5a756d6d..7bfbe9e6ab4 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 5ac798dbc0c..f89c1700a40 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 = Maybe.is_some (Reactive.get live pos) 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 Maybe.is_some (Reactive.get roots pos) 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 594fb08f236..be7c646721c 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 -> Maybe.to_option (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/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index 243f1fc1c07..eb3215e42f3 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -74,20 +74,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 d2ba76e58e9..603f06cdffb 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.inner) Reactive.t; roots: (Lexing.position, unit) Reactive.t; } @@ -21,13 +21,20 @@ let create ~(merged : ReactiveMerge.t) : t = let value_refs_from : (Lexing.position, PosSet.t) Reactive.t = Reactive.Union.create ~name:"liveness.value_refs_from" merged.value_refs_from merged.exception_refs.resolved_refs_from - ~merge:PosSet.union () + ~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.create ~name:"liveness.type_refs_from" merged.type_refs_from - merged.type_deps.all_type_refs_from ~merge:PosSet.union () + 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) *) @@ -36,11 +43,11 @@ 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 = + let edges : (Lexing.position, Lexing.position StableList.inner) Reactive.t = Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index ~f:(fun pos (value_targets, type_targets) emit -> let all_targets = PosSet.union value_targets type_targets in - emit pos (PosSet.elements all_targets)) + emit pos (StableList.unsafe_inner_of_list (PosSet.elements all_targets))) () in @@ -82,7 +89,7 @@ let create ~(merged : ReactiveMerge.t) : t = let externally_referenced : (Lexing.position, unit) Reactive.t = Reactive.Union.create ~name:"liveness.externally_referenced" external_value_refs external_type_refs - ~merge:(fun () () -> ()) + ~merge:(fun _ _ -> Stable.unit) () in @@ -103,7 +110,7 @@ let create ~(merged : ReactiveMerge.t) : t = let all_roots : (Lexing.position, unit) Reactive.t = Reactive.Union.create ~name:"liveness.all_roots" annotated_roots externally_referenced - ~merge:(fun () () -> ()) + ~merge:(fun _ _ -> Stable.unit) () in diff --git a/analysis/reanalyze/src/ReactiveLiveness.mli b/analysis/reanalyze/src/ReactiveLiveness.mli index e0b5fcf53af..3602b196646 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.inner) Reactive.t; roots: (Lexing.position, unit) Reactive.t; } diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index f5e485af41a..f44cf7c6f99 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -162,13 +162,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. @@ -190,26 +200,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; @@ -217,9 +230,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 @@ -231,6 +245,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; @@ -247,17 +262,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 @@ -270,6 +291,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/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index 33be66fef0c..3e3ad5ac368 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -123,9 +123,9 @@ 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) = - let ann = Reactive.get annotations decl.pos in + let ann = Reactive.get annotations (Stable.unsafe_of_value decl.pos) in if Maybe.is_some ann then - match Maybe.unsafe_get ann with + match Stable.to_linear_value (Maybe.unsafe_get ann) with | FileAnnotations.Live -> false | FileAnnotations.GenType -> false | FileAnnotations.Dead -> false @@ -145,7 +145,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 @@ -252,9 +256,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 - let dm = Reactive.get dead_modules moduleName in + let dm = Reactive.get dead_modules (Stable.unsafe_of_value moduleName) in if Maybe.is_some dm then ( - let loc, fileName = Maybe.unsafe_get dm in + 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 @@ -283,7 +287,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" @@ -302,7 +307,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; @@ -311,7 +317,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 @@ -328,14 +335,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 = - let d = Reactive.get t.decls pos in + 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) + 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 064e01f0917..286ed3555b7 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -217,14 +217,27 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let combined_refs_to = let u1 = Reactive.Union.create ~name:"type_deps.u1" same_path_refs - cross_file_refs ~merge:PosSet.union () + 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.create ~name:"type_deps.u2" u1 impl_to_intf_refs_path2 - ~merge:PosSet.union () + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) + (Stable.to_linear_value b))) + () in Reactive.Union.create ~name:"type_deps.combined_refs_to" u2 - intf_to_impl_refs ~merge:PosSet.union () + 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.create ~name:"type_deps.all_type_refs_from" @@ -252,7 +265,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 6aa74de4df4..8a8881419d1 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 = - Maybe.to_option (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 From 7b65b20ecd9b099a898865732a6ddc5e6412da93 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 20:22:59 +0100 Subject: [PATCH 42/54] analysis/reactive: make ReactiveFlatMap.ml stable-safe Thread Stable.t through f/merge callbacks and internal mutable state (current_k1, merge_acc, emit_fn) to eliminate all 23 unsafe_of_value calls. Push boundary wrapping to callers in tests and reanalyze. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Reactive.mli | 8 ++- analysis/reactive/src/ReactiveFlatMap.ml | 72 +++++++------------ analysis/reactive/src/ReactiveFlatMap.mli | 8 ++- analysis/reactive/test/BatchTest.ml | 5 +- analysis/reactive/test/FlatMapTest.ml | 33 ++++++--- analysis/reactive/test/GlitchFreeTest.ml | 64 ++++++++++++----- analysis/reactive/test/IntegrationTest.ml | 12 +++- analysis/reanalyze/src/ReactiveAnalysis.ml | 6 +- analysis/reanalyze/src/ReactiveDeclRefs.ml | 12 +++- .../reanalyze/src/ReactiveExceptionRefs.ml | 17 +++-- analysis/reanalyze/src/ReactiveLiveness.ml | 9 ++- analysis/reanalyze/src/ReactiveMerge.ml | 65 ++++++++++++----- analysis/reanalyze/src/ReactiveSolver.ml | 42 ++++++++--- analysis/reanalyze/src/ReactiveTypeDeps.ml | 53 ++++++++++---- 14 files changed, 271 insertions(+), 135 deletions(-) diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index 011eb61863c..f6520dff4ee 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -111,8 +111,12 @@ module FlatMap : sig val create : name:string -> ('k1, 'v1) t -> - f:('k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> - ?merge:('v2 -> 'v2 -> 'v2) -> + f: + ('k1 Stable.t -> + 'v1 Stable.t -> + ('k2 Stable.t -> 'v2 Stable.t -> unit) -> + unit) -> + ?merge:('v2 Stable.t -> 'v2 Stable.t -> 'v2 Stable.t) -> unit -> ('k2, 'v2) t (** Transform each entry into zero or more output entries. diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index af4299ec0d1..21df1e8ba22 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -1,8 +1,12 @@ (** Zero-allocation (steady-state) flatMap state and processing logic. *) type ('k1, 'v1, 'k2, 'v2) t = { - f: 'k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit; - merge: 'v2 -> 'v2 -> 'v2; + f: + 'k1 Stable.t -> + 'v1 Stable.t -> + ('k2 Stable.t -> 'v2 Stable.t -> unit) -> + unit; + merge: 'v2 Stable.t -> 'v2 Stable.t -> 'v2 Stable.t; (* Persistent state *) provenance: ('k1, 'k2) StableMapSet.t; contributions: ('k2, 'k1, 'v2) StableMapMap.t; @@ -13,13 +17,13 @@ type ('k1, 'v1, 'k2, 'v2) t = { (* Pre-allocated output buffer *) output_wave: ('k2, 'v2 Maybe.t) StableWave.t; (* Emit callback state — allocated once, reused per entry *) - mutable current_k1: 'k1; - emit_fn: 'k2 -> 'v2 -> unit; + mutable current_k1: 'k1 Stable.t; + emit_fn: 'k2 Stable.t -> 'v2 Stable.t -> unit; (* Mutable stats — allocated once, returned by process() *) result: process_result; (* Mutable merge state for recompute_target *) mutable merge_first: bool; - mutable merge_acc: 'v2; + mutable merge_acc: 'v2 Stable.t; } and process_result = { @@ -33,27 +37,15 @@ and process_result = { (* Emit callback for steady-state — marks affected *) let add_single_contribution (t : (_, _, _, _) t) k2 v2 = - StableMapSet.add t.provenance - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value k2); - StableMapMap.replace t.contributions - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value v2); - StableSet.add t.affected (Stable.unsafe_of_value k2) + StableMapSet.add t.provenance t.current_k1 k2; + StableMapMap.replace t.contributions k2 t.current_k1 v2; + StableSet.add t.affected k2 (* Emit callback for init — writes directly to target *) let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = - StableMapSet.add t.provenance - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value k2); - StableMapMap.replace t.contributions - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value v2); - StableMap.replace t.target - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value v2) + StableMapSet.add t.provenance t.current_k1 k2; + StableMapMap.replace t.contributions k2 t.current_k1 v2; + StableMap.replace t.target k2 v2 let create ~f ~merge = let rec t = @@ -98,45 +90,33 @@ 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 - (Stable.unsafe_of_value t.current_k1); + t.current_k1; StableSet.add t.affected k2 let remove_source (t : (_, _, _, _) t) k1 = t.current_k1 <- k1; - StableMapSet.drain_key t.provenance - (Stable.unsafe_of_value k1) - t remove_one_contribution + 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 = - let v = Stable.to_linear_value v in if t.merge_first then ( t.merge_acc <- v; t.merge_first <- false) else t.merge_acc <- t.merge t.merge_acc v let recompute_target (t : (_, _, _, _) t) k2 = - let k2 = Stable.to_linear_value k2 in - if StableMapMap.inner_cardinal t.contributions (Stable.unsafe_of_value k2) > 0 - then ( + if StableMapMap.inner_cardinal t.contributions k2 > 0 then ( t.merge_first <- true; - StableMapMap.iter_inner_with t.contributions - (Stable.unsafe_of_value k2) - t merge_one_contribution; - StableMap.replace t.target - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value t.merge_acc); - StableWave.push t.output_wave - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value (Maybe.some t.merge_acc))) + StableMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; + StableMap.replace t.target k2 t.merge_acc; + StableWave.push t.output_wave k2 (Maybe.to_stable (Maybe.some t.merge_acc))) else ( - StableMap.remove t.target (Stable.unsafe_of_value k2); - StableWave.push t.output_wave (Stable.unsafe_of_value k2) Maybe.none_stable) + 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 k1 = Stable.to_linear_value k1 in - let mv = Stable.to_linear_value mv in + 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 ( @@ -147,7 +127,7 @@ let process_scratch_entry (t : (_, _, _, _) t) k1 mv = else t.result.removes_received <- t.result.removes_received + 1 let count_output_entry (r : process_result) _k mv = - let mv = Stable.to_linear_value mv in + 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 @@ -174,8 +154,6 @@ let process (t : (_, _, _, _) t) = r let init_entry (t : (_, _, _, _) t) k1 v1 = - let k1 = Stable.to_linear_value k1 in - let v1 = Stable.to_linear_value v1 in t.current_k1 <- k1; t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index f7c34163029..be8cc928608 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -14,8 +14,12 @@ type process_result = { } val create : - f:('k1 -> 'v1 -> ('k2 -> 'v2 -> unit) -> unit) -> - merge:('v2 -> 'v2 -> 'v2) -> + f: + ('k1 Stable.t -> + 'v1 Stable.t -> + ('k2 Stable.t -> 'v2 Stable.t -> unit) -> + unit) -> + merge:('v2 Stable.t -> 'v2 Stable.t -> 'v2 Stable.t) -> ('k1, 'v1, 'k2, 'v2) t val destroy : ('k1, 'v1, 'k2, 'v2) t -> unit diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index 909497e7b44..e57e6010c2d 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -10,7 +10,10 @@ let test_batch_flatmap () = let source, emit = Source.create ~name:"source" () in let derived = FlatMap.create ~name:"derived" source - ~f:(fun k v emit -> emit (k ^ "_derived") (v * 2)) + ~f:(fun k v emit -> + emit + (Stable.unsafe_of_value (Stable.to_linear_value k ^ "_derived")) + (Stable.int (Stable.to_linear_value v * 2))) () in diff --git a/analysis/reactive/test/FlatMapTest.ml b/analysis/reactive/test/FlatMapTest.ml index 1dfc874d7cd..905b59024aa 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/FlatMapTest.ml @@ -14,9 +14,10 @@ let test_flatmap_basic () = let derived = FlatMap.create ~name:"derived" source ~f:(fun key value emit -> - emit (key * 10) value; - emit ((key * 10) + 1) value; - emit ((key * 10) + 2) value) + let key = Stable.to_linear_value key in + emit (Stable.int (key * 10)) value; + emit (Stable.int ((key * 10) + 1)) value; + emit (Stable.int ((key * 10) + 2)) value) () in @@ -59,8 +60,12 @@ let test_flatmap_with_merge () = (* Create derived with merge *) let derived = FlatMap.create ~name:"derived" source - ~f:(fun _key values emit -> emit 0 values) (* all contribute to key 0 *) - ~merge:IntSet.union () + ~f:(fun _key values emit -> emit (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} *) @@ -97,9 +102,13 @@ let test_composition () = let items = FlatMap.create ~name:"items" source ~f:(fun path items emit -> + let path = Stable.to_linear_value path in List.iteri - (fun i item -> emit (Printf.sprintf "%s:%d" path i) item) - items) + (fun i item -> + emit + (Stable.unsafe_of_value (Printf.sprintf "%s:%d" path i)) + (Stable.unsafe_of_value item)) + (Stable.to_linear_value items)) () in @@ -107,7 +116,13 @@ let test_composition () = let chars = FlatMap.create ~name:"chars" items ~f:(fun key value emit -> - String.iteri (fun i c -> emit (Printf.sprintf "%s:%d" key i) c) value) + let key = Stable.to_linear_value key in + String.iteri + (fun i c -> + emit + (Stable.unsafe_of_value (Printf.sprintf "%s:%d" key i)) + (Stable.unsafe_of_value c)) + (Stable.to_linear_value value)) () in @@ -150,7 +165,7 @@ let test_flatmap_on_existing_data () = (* Create flatMap AFTER source has data *) let derived = FlatMap.create ~name:"derived" source - ~f:(fun k v emit -> emit (k * 10) v) + ~f:(fun k v emit -> emit (Stable.int (Stable.to_linear_value k * 10)) v) () in diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index 49b7d22d3fe..5eea3073c22 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -49,15 +49,22 @@ let test_same_source_anti_join () = let refs = FlatMap.create ~name:"refs" src - ~f:(fun _file (data : file_data) emit -> - List.iter (fun (k, v) -> emit k v) data.refs) + ~f:(fun _file data emit -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + data.refs) () in let decls = FlatMap.create ~name:"decls" src - ~f:(fun _file (data : file_data) emit -> - List.iter (fun pos -> emit pos ()) data.decl_positions) + ~f:(fun _file data emit -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun pos -> emit (Stable.unsafe_of_value pos) Stable.unit) + data.decl_positions) () in @@ -96,9 +103,12 @@ let test_multi_level_union () = (* refs1: level 1 *) let refs1 = FlatMap.create ~name:"refs1" src - ~f:(fun _file (data : file_data) emit -> + ~f:(fun _file data emit -> + let data : file_data = Stable.to_linear_value data in List.iter - (fun (k, v) -> if String.length k > 0 && k.[0] = 'D' then emit k v) + (fun (k, v) -> + if String.length k > 0 && k.[0] = 'D' then + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) data.refs) () in @@ -106,9 +116,12 @@ let test_multi_level_union () = (* intermediate: level 1 *) let intermediate = FlatMap.create ~name:"intermediate" src - ~f:(fun _file (data : file_data) emit -> + ~f:(fun _file data emit -> + let data : file_data = Stable.to_linear_value data in List.iter - (fun (k, v) -> if String.length k > 0 && k.[0] = 'I' then emit k v) + (fun (k, v) -> + if String.length k > 0 && k.[0] = 'I' then + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) data.refs) () in @@ -121,8 +134,11 @@ let test_multi_level_union () = (* decls: level 1 *) let decls = FlatMap.create ~name:"decls" src - ~f:(fun _file (data : file_data) emit -> - List.iter (fun pos -> emit pos ()) data.decl_positions) + ~f:(fun _file data emit -> + let data : file_data = Stable.to_linear_value data in + List.iter + (fun pos -> emit (Stable.unsafe_of_value pos) Stable.unit) + data.decl_positions) () in @@ -162,32 +178,44 @@ let test_real_pipeline_simulation () = (* decls: level 1 *) let decls = FlatMap.create ~name:"decls" src - ~f:(fun _file (data : full_file_data) emit -> - List.iter (fun pos -> emit pos ()) data.full_decls) + ~f:(fun _file data emit -> + let data : full_file_data = Stable.to_linear_value data in + List.iter + (fun pos -> emit (Stable.unsafe_of_value pos) Stable.unit) + data.full_decls) () in (* merged_value_refs: level 1 *) let merged_value_refs = FlatMap.create ~name:"merged_value_refs" src - ~f:(fun _file (data : full_file_data) emit -> - List.iter (fun (k, v) -> emit k v) data.value_refs) + ~f:(fun _file data emit -> + let data : full_file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + data.value_refs) () in (* exception_refs_raw: level 1 *) let exception_refs_raw = FlatMap.create ~name:"exception_refs_raw" src - ~f:(fun _file (data : full_file_data) emit -> - List.iter (fun (k, v) -> emit k v) data.exception_refs) + ~f:(fun _file data emit -> + let data : full_file_data = Stable.to_linear_value data in + List.iter + (fun (k, v) -> + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + data.exception_refs) () in (* exception_decls: level 2 *) let exception_decls = FlatMap.create ~name:"exception_decls" decls - ~f:(fun pos () emit -> - if String.length pos > 0 && pos.[0] = 'E' then emit pos ()) + ~f:(fun pos _unit emit -> + let pos_v = Stable.to_linear_value pos in + if String.length pos_v > 0 && pos_v.[0] = 'E' then emit pos Stable.unit) () in diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/IntegrationTest.ml index 42be1c387f1..100bfe1f277 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -16,16 +16,22 @@ let test_file_collection () = (* First flatMap: aggregate word counts across files with merge *) let word_counts = FlatMap.create ~name:"word_counts" files - ~f:(fun _path counts emit -> StringMap.iter (fun k v -> emit k v) counts) + ~f:(fun _path counts emit -> + StringMap.iter + (fun k v -> emit (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.create ~name:"frequent_words" word_counts - ~f:(fun word count emit -> if count >= 2 then emit word count) + ~f:(fun word count emit -> + if Stable.to_linear_value count >= 2 then emit word count) () in diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index c99cdc79c2c..d6426c79851 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -139,9 +139,11 @@ let to_file_data_collection (collection : t) : Reactive.FlatMap.create ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) ~f:(fun path result_opt emit -> + let result_opt = Stable.to_linear_value result_opt in match result_opt with - | Some {dce_data = Some data; _} -> emit path (Some data) - | _ -> emit path None) + | Some {dce_data = Some data; _} -> + emit path (Stable.unsafe_of_value (Some data)) + | _ -> emit path (Stable.unsafe_of_value None)) () (** Iterate over all file_data in the collection *) diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index b5cc3b334f4..8ee5c7a1ef5 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -15,8 +15,16 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Group declarations by file *) let decls_by_file : (string, (Lexing.position * Decl.t) list) Reactive.t = Reactive.FlatMap.create ~name:"decl_refs.decls_by_file" decls - ~f:(fun pos decl emit -> emit pos.Lexing.pos_fname [(pos, decl)]) - ~merge:( @ ) () + ~f:(fun pos decl emit -> + let pos = Stable.to_linear_value pos in + let decl = Stable.to_linear_value decl in + emit + (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 *) diff --git a/analysis/reanalyze/src/ReactiveExceptionRefs.ml b/analysis/reanalyze/src/ReactiveExceptionRefs.ml index eb3215e42f3..ad3d3538fb9 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -27,7 +27,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 1: Index exception declarations by path *) let exception_decls = Reactive.FlatMap.create ~name:"exc_refs.exception_decls" decls - ~f:(fun _pos (decl : Decl.t) emit -> + ~f:(fun _pos decl emit -> + let decl : Decl.t = Stable.to_linear_value decl in match decl.Decl.declKind with | Exception -> let loc : Location.t = @@ -37,7 +38,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) loc_ghost = false; } in - emit decl.path loc + emit (Stable.unsafe_of_value decl.path) (Stable.unsafe_of_value loc) | _ -> ()) () (* Last-write-wins is fine since paths should be unique *) in @@ -60,10 +61,18 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let resolved_refs_from = Reactive.FlatMap.create ~name:"exc_refs.resolved_refs_from" resolved_refs ~f:(fun posTo posFromSet emit -> + let posTo = Stable.to_linear_value posTo in + let posFromSet = Stable.to_linear_value posFromSet in PosSet.iter - (fun posFrom -> emit posFrom (PosSet.singleton posTo)) + (fun posFrom -> + emit + (Stable.unsafe_of_value posFrom) + (Stable.unsafe_of_value (PosSet.singleton posTo))) posFromSet) - ~merge:PosSet.union () + ~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} diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 603f06cdffb..1fdc4cfa150 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -45,9 +45,14 @@ let create ~(merged : ReactiveMerge.t) : t = (* Step 2: Convert to edges format for fixpoint: decl -> successor list *) let edges : (Lexing.position, Lexing.position StableList.inner) Reactive.t = Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index - ~f:(fun pos (value_targets, type_targets) emit -> + ~f:(fun pos v emit -> + 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 - emit pos (StableList.unsafe_inner_of_list (PosSet.elements all_targets))) + emit + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value + (StableList.unsafe_inner_of_list (PosSet.elements all_targets)))) () in diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index f44cf7c6f99..e3857602ff4 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -27,11 +27,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let decls = Reactive.FlatMap.create ~name:"decls" source ~f:(fun _path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> Declarations.builder_to_list file_data.DceFileProcessing.decls - |> List.iter (fun (k, v) -> emit k v)) + |> List.iter (fun (k, v) -> + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v))) () in @@ -39,12 +41,14 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let annotations = Reactive.FlatMap.create ~name:"annotations" source ~f:(fun _path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> FileAnnotations.builder_to_list file_data.DceFileProcessing.annotations - |> List.iter (fun (k, v) -> emit k v)) + |> List.iter (fun (k, v) -> + emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v))) () in @@ -52,46 +56,60 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let value_refs_from = Reactive.FlatMap.create ~name:"value_refs_from" source ~f:(fun _path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> References.builder_value_refs_from_list file_data.DceFileProcessing.refs - |> List.iter (fun (k, v) -> emit k v)) - ~merge:PosSet.union () + |> List.iter (fun (k, v) -> + emit (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.create ~name:"type_refs_from" source ~f:(fun _path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> References.builder_type_refs_from_list file_data.DceFileProcessing.refs - |> List.iter (fun (k, v) -> emit k v)) - ~merge:PosSet.union () + |> List.iter (fun (k, v) -> + emit (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.create ~name:"cross_file_items" source ~f:(fun path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> let items = CrossFileItems.builder_to_t file_data.DceFileProcessing.cross_file in - emit path items) + emit 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 @@ -99,26 +117,34 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let file_deps_map = Reactive.FlatMap.create ~name:"file_deps_map" source ~f:(fun _path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps - |> List.iter (fun (k, v) -> emit k v)) - ~merge:FileSet.union () + |> List.iter (fun (k, v) -> + emit (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.create ~name:"files" source ~f:(fun _cmt_path file_data_opt emit -> + let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> - (* Include all source files from file_deps (NOT the CMT path) *) let file_set = FileDeps.builder_files file_data.DceFileProcessing.file_deps in - FileSet.iter (fun f -> emit f ()) file_set) + FileSet.iter + (fun f -> + emit (Stable.unsafe_of_value f) (Stable.unsafe_of_value ())) + file_set) () in @@ -126,9 +152,12 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let exception_refs_collection = Reactive.FlatMap.create ~name:"exception_refs_collection" cross_file_items ~f:(fun _path items emit -> + let items = Stable.to_linear_value items in items.CrossFileItems.exception_refs |> List.iter (fun (r : CrossFileItems.exception_ref) -> - emit r.exception_path r.loc_from)) + emit + (Stable.unsafe_of_value r.exception_path) + (Stable.unsafe_of_value r.loc_from))) () in diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index 3e3ad5ac368..58ae53e84b6 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -83,15 +83,22 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let modules_with_dead = Reactive.FlatMap.create ~name:"solver.modules_with_dead" dead_decls ~f:(fun _pos decl emit -> - emit (decl_module_name decl) - (decl.moduleLoc, decl.pos.Lexing.pos_fname)) + let decl = Stable.to_linear_value decl in + emit + (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.create ~name:"solver.modules_with_live" live_decls - ~f:(fun _pos decl emit -> emit (decl_module_name decl) ()) + ~f:(fun _pos decl emit -> + let decl = Stable.to_linear_value decl in + emit + (Stable.unsafe_of_value (decl_module_name decl)) + (Stable.unsafe_of_value ())) () in (* Anti-join: modules in dead but not in live *) @@ -107,8 +114,14 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Reactive per-file grouping of dead declarations *) let dead_decls_by_file = Reactive.FlatMap.create ~name:"solver.dead_decls_by_file" dead_decls - ~f:(fun _pos decl emit -> emit decl.pos.Lexing.pos_fname [decl]) - ~merge:(fun decls1 decls2 -> decls1 @ decls2) + ~f:(fun _pos decl emit -> + let decl = Stable.to_linear_value decl in + emit + (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 @@ -169,15 +182,21 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) match (transitive, value_refs_from) with | true, _ | false, None -> Reactive.FlatMap.create ~name:"solver.issues_by_file" dead_decls_by_file - ~f:(fun file decls emit -> emit file (issues_for_file file decls)) + ~f:(fun file decls emit -> + let file = Stable.to_linear_value file in + let decls = Stable.to_linear_value decls in + emit + (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.create ~name:"solver.refs_token" refs_from - ~f:(fun _posFrom _targets emit -> emit () ()) - ~merge:(fun _ _ -> ()) + ~f:(fun _posFrom _targets emit -> + emit (Stable.unsafe_of_value ()) (Stable.unsafe_of_value ())) + ~merge:(fun _ _ -> Stable.unsafe_of_value ()) () in Reactive.Join.create ~name:"solver.issues_by_file" dead_decls_by_file @@ -204,8 +223,11 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Reactive modules_with_reported: modules that have at least one reported dead value *) let modules_with_reported = Reactive.FlatMap.create ~name:"solver.modules_with_reported" issues_by_file - ~f:(fun _file (_issues, modules_list) emit -> - List.iter (fun m -> emit m ()) modules_list) + ~f:(fun _file v emit -> + let _issues, modules_list = Stable.to_linear_value v in + List.iter + (fun m -> emit (Stable.unsafe_of_value m) (Stable.unsafe_of_value ())) + modules_list) () in diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 286ed3555b7..922d74d650c 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -51,30 +51,40 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let decl_by_path = Reactive.FlatMap.create ~name:"type_deps.decl_by_path" decls ~f:(fun _pos decl emit -> + let decl = Stable.to_linear_value decl in match decl_to_info decl with - | Some info -> emit info.path [info] + | Some info -> + emit + (Stable.unsafe_of_value info.path) + (Stable.unsafe_of_value [info]) | None -> ()) - ~merge:List.append () + ~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.create ~name:"type_deps.same_path_refs" decl_by_path ~f:(fun _path decls emit -> + 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.iter (fun other -> - (* Always add: other -> first (posTo=other, posFrom=first) *) - emit other.pos (PosSet.singleton first.pos); + emit + (Stable.unsafe_of_value other.pos) + (Stable.unsafe_of_value (PosSet.singleton first.pos)); if not report_types_dead_only_in_interface then - (* Also add: first -> other (posTo=first, posFrom=other) *) - emit first.pos (PosSet.singleton other.pos))) - ~merge:PosSet.union () + emit + (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 *) @@ -82,17 +92,19 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let impl_decls = Reactive.FlatMap.create ~name:"type_deps.impl_decls" decls ~f:(fun _pos decl emit -> + 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 - emit info.pos (info, intf_path1, intf_path2)) + emit + (Stable.unsafe_of_value info.pos) + (Stable.unsafe_of_value (info, intf_path1, intf_path2))) | _ -> ()) () in @@ -158,6 +170,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let intf_decls = Reactive.FlatMap.create ~name:"type_deps.intf_decls" decls ~f:(fun _pos decl emit -> + let decl = Stable.to_linear_value decl in match decl_to_info decl with | Some info when info.is_interface -> ( match info.path with @@ -166,7 +179,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let impl_path = typeLabelName :: DcePath.moduleToImplementation pathToType in - emit info.pos (info, impl_path)) + emit + (Stable.unsafe_of_value info.pos) + (Stable.unsafe_of_value (info, impl_path))) | _ -> ()) () in @@ -243,10 +258,18 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.FlatMap.create ~name:"type_deps.all_type_refs_from" combined_refs_to ~f:(fun posTo posFromSet emit -> + let posTo = Stable.to_linear_value posTo in + let posFromSet = Stable.to_linear_value posFromSet in PosSet.iter - (fun posFrom -> emit posFrom (PosSet.singleton posTo)) + (fun posFrom -> + emit + (Stable.unsafe_of_value posFrom) + (Stable.unsafe_of_value (PosSet.singleton posTo))) posFromSet) - ~merge:PosSet.union () + ~merge:(fun a b -> + Stable.unsafe_of_value + (PosSet.union (Stable.to_linear_value a) (Stable.to_linear_value b))) + () in { From 61de83d0dbf9adabf022dfcac934a46d7c11d481 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 21:29:47 +0100 Subject: [PATCH 43/54] analysis/reactive: wave-based emit for FlatMap/Join, make ReactiveJoin stable-safe, fix right_tbl leak Replace emit callback with StableWave in FlatMap and Join: f now receives a wave and pushes to it, eliminating let rec + Obj.magic + emit_fn field. Use Maybe.none sentinels for mutable fields and Maybe.t merge accumulator. Make ReactiveJoin.ml fully stable-safe (zero unsafe_of_value calls). Fix pre-existing right_tbl leak in test_join_alloc_n (missing destroy). Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Reactive.mli | 17 +- analysis/reactive/src/ReactiveFlatMap.ml | 115 ++++----- analysis/reactive/src/ReactiveFlatMap.mli | 6 +- analysis/reactive/src/ReactiveJoin.ml | 241 +++++++----------- analysis/reactive/src/ReactiveJoin.mli | 11 +- analysis/reactive/test/AllocTest.ml | 23 +- analysis/reactive/test/BatchTest.ml | 4 +- analysis/reactive/test/FlatMapTest.ml | 21 +- analysis/reactive/test/GlitchFreeTest.ml | 91 ++++--- analysis/reactive/test/IntegrationTest.ml | 10 +- analysis/reactive/test/JoinTest.ml | 16 +- analysis/reanalyze/src/ReactiveAnalysis.ml | 6 +- analysis/reanalyze/src/ReactiveDeclRefs.ml | 77 ++++-- .../reanalyze/src/ReactiveExceptionRefs.ml | 26 +- analysis/reanalyze/src/ReactiveLiveness.ml | 32 ++- analysis/reanalyze/src/ReactiveMerge.ml | 38 +-- analysis/reanalyze/src/ReactiveSolver.ml | 72 +++--- analysis/reanalyze/src/ReactiveTypeDeps.ml | 103 +++++--- 18 files changed, 506 insertions(+), 403 deletions(-) diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index f6520dff4ee..2dcc5c8f5c8 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -111,11 +111,7 @@ module FlatMap : sig val create : name:string -> ('k1, 'v1) t -> - f: - ('k1 Stable.t -> - 'v1 Stable.t -> - ('k2 Stable.t -> 'v2 Stable.t -> unit) -> - unit) -> + 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 @@ -128,9 +124,14 @@ module Join : sig name:string -> ('k1, 'v1) t -> ('k2, 'v2) t -> - key_of:('k1 -> 'v1 -> 'k2) -> - f:('k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> - ?merge:('v3 -> 'v3 -> 'v3) -> + 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. diff --git a/analysis/reactive/src/ReactiveFlatMap.ml b/analysis/reactive/src/ReactiveFlatMap.ml index 21df1e8ba22..6a68b925185 100644 --- a/analysis/reactive/src/ReactiveFlatMap.ml +++ b/analysis/reactive/src/ReactiveFlatMap.ml @@ -1,11 +1,7 @@ (** Zero-allocation (steady-state) flatMap state and processing logic. *) type ('k1, 'v1, 'k2, 'v2) t = { - f: - 'k1 Stable.t -> - 'v1 Stable.t -> - ('k2 Stable.t -> 'v2 Stable.t -> unit) -> - unit; + 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; @@ -16,14 +12,14 @@ type ('k1, 'v1, 'k2, 'v2) t = { affected: 'k2 StableSet.t; (* Pre-allocated output buffer *) output_wave: ('k2, 'v2 Maybe.t) StableWave.t; - (* Emit callback state — allocated once, reused per entry *) - mutable current_k1: 'k1 Stable.t; - emit_fn: 'k2 Stable.t -> 'v2 Stable.t -> unit; + (* 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; - (* Mutable merge state for recompute_target *) - mutable merge_first: bool; - mutable merge_acc: 'v2 Stable.t; + (* Merge accumulator for recompute_target — Maybe.none = first element *) + mutable merge_acc: 'v2 Stable.t Maybe.t; } and process_result = { @@ -35,45 +31,43 @@ and process_result = { mutable removes_emitted: int; } -(* Emit callback for steady-state — marks affected *) -let add_single_contribution (t : (_, _, _, _) t) k2 v2 = - StableMapSet.add t.provenance t.current_k1 k2; - StableMapMap.replace t.contributions k2 t.current_k1 v2; +(* 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 -(* Emit callback for init — writes directly to target *) -let add_single_contribution_init (t : (_, _, _, _) t) k2 v2 = - StableMapSet.add t.provenance t.current_k1 k2; - StableMapMap.replace t.contributions k2 t.current_k1 v2; +(* 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 = - let rec t = - { - f; - merge; - provenance = StableMapSet.create (); - contributions = StableMapMap.create (); - target = StableMap.create (); - scratch = StableMap.create (); - affected = StableSet.create (); - output_wave = StableWave.create (); - current_k1 = Obj.magic (); - emit_fn = (fun k2 v2 -> add_single_contribution t k2 v2); - result = - { - entries_received = 0; - adds_received = 0; - removes_received = 0; - entries_emitted = 0; - adds_emitted = 0; - removes_emitted = 0; - }; - merge_first = true; - merge_acc = Obj.magic (); - } - in - t + { + 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; @@ -81,7 +75,8 @@ let destroy t = StableMap.destroy t.target; StableMap.destroy t.scratch; StableSet.destroy t.affected; - StableWave.destroy t.output_wave + StableWave.destroy t.output_wave; + StableWave.destroy t.emit_wave let output_wave t = t.output_wave @@ -90,26 +85,24 @@ 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 - t.current_k1; + (Maybe.unsafe_get t.current_k1); StableSet.add t.affected k2 let remove_source (t : (_, _, _, _) t) k1 = - t.current_k1 <- 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 t.merge_first then ( - t.merge_acc <- v; - t.merge_first <- false) - else t.merge_acc <- t.merge t.merge_acc 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_first <- true; + t.merge_acc <- Maybe.none; StableMapMap.iter_inner_with t.contributions k2 t merge_one_contribution; - StableMap.replace t.target k2 t.merge_acc; - StableWave.push t.output_wave k2 (Maybe.to_stable (Maybe.some t.merge_acc))) + 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) @@ -122,8 +115,10 @@ let process_scratch_entry (t : (_, _, _, _) t) k1 mv = 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 <- k1; - t.f k1 v1 t.emit_fn) + 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 = @@ -154,8 +149,10 @@ let process (t : (_, _, _, _) t) = r let init_entry (t : (_, _, _, _) t) k1 v1 = - t.current_k1 <- k1; - t.f k1 v1 (fun k2 v2 -> add_single_contribution_init t k2 v2) + 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 diff --git a/analysis/reactive/src/ReactiveFlatMap.mli b/analysis/reactive/src/ReactiveFlatMap.mli index be8cc928608..e9ef8b53104 100644 --- a/analysis/reactive/src/ReactiveFlatMap.mli +++ b/analysis/reactive/src/ReactiveFlatMap.mli @@ -14,11 +14,7 @@ type process_result = { } val create : - f: - ('k1 Stable.t -> - 'v1 Stable.t -> - ('k2 Stable.t -> 'v2 Stable.t -> unit) -> - unit) -> + 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 diff --git a/analysis/reactive/src/ReactiveJoin.ml b/analysis/reactive/src/ReactiveJoin.ml index 1b5cc10e152..de699b69bce 100644 --- a/analysis/reactive/src/ReactiveJoin.ml +++ b/analysis/reactive/src/ReactiveJoin.ml @@ -1,9 +1,14 @@ (** Zero-allocation (steady-state) join state and processing logic. *) type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { - key_of: 'k1 -> 'v1 -> 'k2; - f: 'k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit; - merge: 'v3 -> 'v3 -> 'v3; + 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; @@ -18,14 +23,14 @@ type ('k1, 'v1, 'k2, 'v2, 'k3, 'v3) t = { affected: 'k3 StableSet.t; (* Pre-allocated output buffer *) output_wave: ('k3, 'v3 Maybe.t) StableWave.t; - (* Emit callback state — allocated once, reused per entry *) - mutable current_k1: 'k1; - emit_fn: 'k3 -> 'v3 -> unit; + (* 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; - (* Mutable merge state for recompute_target *) - mutable merge_first: bool; - mutable merge_acc: 'v3; + (* Merge accumulator for recompute_target — Maybe.none = first element *) + mutable merge_acc: 'v3 Stable.t Maybe.t; } and process_result = { @@ -37,63 +42,49 @@ and process_result = { mutable removes_emitted: int; } -(* Emit callback for steady-state — marks affected *) -let add_single_contribution (t : (_, _, _, _, _, _) t) k3 v3 = - StableMapSet.add t.provenance - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value k3); - StableMapMap.replace t.contributions - (Stable.unsafe_of_value k3) - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value v3); - StableSet.add t.affected (Stable.unsafe_of_value k3) +(* 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 -(* Emit callback for init — writes directly to target *) -let add_single_contribution_init (t : (_, _, _, _, _, _) t) k3 v3 = - StableMapSet.add t.provenance - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value k3); - StableMapMap.replace t.contributions - (Stable.unsafe_of_value k3) - (Stable.unsafe_of_value t.current_k1) - (Stable.unsafe_of_value v3); - StableMap.replace t.target - (Stable.unsafe_of_value k3) - (Stable.unsafe_of_value v3) +(* 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 = - let rec t = - { - 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 (); - current_k1 = Obj.magic (); - emit_fn = (fun k3 v3 -> add_single_contribution t k3 v3); - result = - { - entries_received = 0; - adds_received = 0; - removes_received = 0; - entries_emitted = 0; - adds_emitted = 0; - removes_emitted = 0; - }; - merge_first = true; - merge_acc = Obj.magic (); - } - in - t + { + 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; @@ -105,7 +96,8 @@ let destroy t = StableMap.destroy t.left_scratch; StableMap.destroy t.right_scratch; StableSet.destroy t.affected; - StableWave.destroy t.output_wave + StableWave.destroy t.output_wave; + StableWave.destroy t.emit_wave let output_wave t = t.output_wave @@ -116,85 +108,61 @@ 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 - (Stable.unsafe_of_value t.current_k1); + (Maybe.unsafe_get t.current_k1); StableSet.add t.affected k3 let remove_left_contributions (t : (_, _, _, _, _, _) t) k1 = - t.current_k1 <- k1; - StableMapSet.drain_key t.provenance - (Stable.unsafe_of_value k1) - t remove_one_contribution_key + 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 (Stable.unsafe_of_value k1) - in + let mb = StableMap.find_maybe t.left_to_right_key k1 in if Maybe.is_some mb then ( - let old_k2 = Stable.to_linear_value (Maybe.unsafe_get mb) in - StableMap.remove t.left_to_right_key (Stable.unsafe_of_value k1); + 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 - (Stable.unsafe_of_value old_k2) - (Stable.unsafe_of_value k1)) + 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 - (Stable.unsafe_of_value k1) - (Stable.unsafe_of_value k2); - StableMapSet.add t.right_key_to_left_keys - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value k1); - let right_val = - Stable.to_linear_value - (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) - in - t.current_k1 <- k1; - t.f k1 v1 right_val t.emit_fn + 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 (Stable.unsafe_of_value 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 = - let v = Stable.to_linear_value v in - if t.merge_first then ( - t.merge_acc <- v; - t.merge_first <- false) - else t.merge_acc <- t.merge t.merge_acc 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 = - let k3 = Stable.to_linear_value k3 in - if StableMapMap.inner_cardinal t.contributions (Stable.unsafe_of_value k3) > 0 - then ( - t.merge_first <- true; - StableMapMap.iter_inner_with t.contributions - (Stable.unsafe_of_value k3) - t merge_one_contribution; - StableMap.replace t.target - (Stable.unsafe_of_value k3) - (Stable.unsafe_of_value t.merge_acc); - StableWave.push t.output_wave - (Stable.unsafe_of_value k3) - (Stable.unsafe_of_value (Maybe.some t.merge_acc))) + 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 (Stable.unsafe_of_value k3); - StableWave.push t.output_wave (Stable.unsafe_of_value k3) Maybe.none_stable) + 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 k1 = Stable.to_linear_value k1 in - let mv = Stable.to_linear_value mv in + 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 - (Stable.unsafe_of_value k1) - (Stable.unsafe_of_value v1); + StableMap.replace t.left_entries k1 v1; process_left_entry t k1 v1) else ( t.result.removes_received <- t.result.removes_received + 1; @@ -202,24 +170,20 @@ let process_left_scratch_entry (t : (_, _, _, _, _, _) t) k1 mv = (* Reprocess a left entry when its right key changed *) let reprocess_left_entry (t : (_, _, _, _, _, _) t) k1 = - let k1 = Stable.to_linear_value k1 in - let mb = StableMap.find_maybe t.left_entries (Stable.unsafe_of_value k1) in - if Maybe.is_some mb then - process_left_entry t k1 (Stable.to_linear_value (Maybe.unsafe_get mb)) + 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 k2 = Stable.to_linear_value k2 in - let _mv = Stable.to_linear_value _mv in +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 + 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 - (Stable.unsafe_of_value k2) - t reprocess_left_entry + 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 = Stable.to_linear_value mv in + 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 @@ -249,24 +213,15 @@ let process (t : (_, _, _, _, _, _) t) = r let init_entry (t : (_, _, _, _, _, _) t) k1 v1 = - let k1 = Stable.to_linear_value k1 in - let v1 = Stable.to_linear_value v1 in - StableMap.replace t.left_entries - (Stable.unsafe_of_value k1) - (Stable.unsafe_of_value v1); + StableMap.replace t.left_entries k1 v1; let k2 = t.key_of k1 v1 in - StableMap.replace t.left_to_right_key - (Stable.unsafe_of_value k1) - (Stable.unsafe_of_value k2); - StableMapSet.add t.right_key_to_left_keys - (Stable.unsafe_of_value k2) - (Stable.unsafe_of_value k1); - let right_val = - Stable.to_linear_value - (Maybe.to_stable (t.right_get (Stable.unsafe_of_value k2))) - in - t.current_k1 <- k1; - t.f k1 v1 right_val (fun k3 v3 -> add_single_contribution_init t k3 v3) + 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 diff --git a/analysis/reactive/src/ReactiveJoin.mli b/analysis/reactive/src/ReactiveJoin.mli index a7c25480c07..33a465da353 100644 --- a/analysis/reactive/src/ReactiveJoin.mli +++ b/analysis/reactive/src/ReactiveJoin.mli @@ -14,9 +14,14 @@ type process_result = { } val create : - key_of:('k1 -> 'v1 -> 'k2) -> - f:('k1 -> 'v1 -> 'v2 Maybe.t -> ('k3 -> 'v3 -> unit) -> unit) -> - merge:('v3 -> 'v3 -> 'v3) -> + 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 diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index c0c6a32af15..937882857d3 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -92,7 +92,9 @@ let test_fixpoint_alloc () = let test_flatmap_alloc_n n = let state = - ReactiveFlatMap.create ~f:(fun k v emit -> emit k v) ~merge:(fun _l r -> r) + ReactiveFlatMap.create + ~f:(fun k v wave -> StableWave.push wave k v) + ~merge:(fun _l r -> r) in (* Populate: n entries *) @@ -211,8 +213,11 @@ let test_join_alloc_n n = let state = ReactiveJoin.create ~key_of:(fun k _v -> k) - ~f:(fun k v right_mb emit -> - if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) + ~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 @@ -266,6 +271,7 @@ let test_join_alloc_n n = done; assert (ReactiveJoin.target_length state = n); ReactiveJoin.destroy state; + StableMap.destroy right_tbl; words_since () / iters let test_join_alloc () = @@ -290,8 +296,11 @@ let test_reactive_join_alloc_n n = let joined = Reactive.Join.create ~name:"joined" left right ~key_of:(fun k _v -> k) - ~f:(fun k v right_mb emit -> - if Maybe.is_some right_mb then emit k (v + Maybe.unsafe_get right_mb)) + ~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 @@ -478,7 +487,9 @@ let test_reactive_flatmap_alloc_n n = let src, emit_src = Reactive.Source.create ~name:"src" () in let derived = - Reactive.FlatMap.create ~name:"derived" src ~f:(fun k v emit -> emit k v) () + Reactive.FlatMap.create ~name:"derived" src + ~f:(fun k v wave -> StableWave.push wave k v) + () in (* Populate: n entries *) diff --git a/analysis/reactive/test/BatchTest.ml b/analysis/reactive/test/BatchTest.ml index e57e6010c2d..b4072266001 100644 --- a/analysis/reactive/test/BatchTest.ml +++ b/analysis/reactive/test/BatchTest.ml @@ -10,8 +10,8 @@ let test_batch_flatmap () = let source, emit = Source.create ~name:"source" () in let derived = FlatMap.create ~name:"derived" source - ~f:(fun k v emit -> - emit + ~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))) () diff --git a/analysis/reactive/test/FlatMapTest.ml b/analysis/reactive/test/FlatMapTest.ml index 905b59024aa..6dfe5870ce7 100644 --- a/analysis/reactive/test/FlatMapTest.ml +++ b/analysis/reactive/test/FlatMapTest.ml @@ -13,11 +13,11 @@ let test_flatmap_basic () = (* Create derived collection via flatMap *) let derived = FlatMap.create ~name:"derived" source - ~f:(fun key value emit -> + ~f:(fun key value wave -> let key = Stable.to_linear_value key in - emit (Stable.int (key * 10)) value; - emit (Stable.int ((key * 10) + 1)) value; - emit (Stable.int ((key * 10) + 2)) value) + 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 @@ -60,7 +60,7 @@ let test_flatmap_with_merge () = (* Create derived with merge *) let derived = FlatMap.create ~name:"derived" source - ~f:(fun _key values emit -> emit (Stable.int 0) values) + ~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 @@ -101,11 +101,11 @@ let test_composition () = (* First flatMap: file -> items *) let items = FlatMap.create ~name:"items" source - ~f:(fun path items emit -> + ~f:(fun path items wave -> let path = Stable.to_linear_value path in List.iteri (fun i item -> - emit + StableWave.push wave (Stable.unsafe_of_value (Printf.sprintf "%s:%d" path i)) (Stable.unsafe_of_value item)) (Stable.to_linear_value items)) @@ -115,11 +115,11 @@ let test_composition () = (* Second flatMap: item -> chars *) let chars = FlatMap.create ~name:"chars" items - ~f:(fun key value emit -> + ~f:(fun key value wave -> let key = Stable.to_linear_value key in String.iteri (fun i c -> - emit + StableWave.push wave (Stable.unsafe_of_value (Printf.sprintf "%s:%d" key i)) (Stable.unsafe_of_value c)) (Stable.to_linear_value value)) @@ -165,7 +165,8 @@ let test_flatmap_on_existing_data () = (* Create flatMap AFTER source has data *) let derived = FlatMap.create ~name:"derived" source - ~f:(fun k v emit -> emit (Stable.int (Stable.to_linear_value k * 10)) v) + ~f:(fun k v wave -> + StableWave.push wave (Stable.int (Stable.to_linear_value k * 10)) v) () in diff --git a/analysis/reactive/test/GlitchFreeTest.ml b/analysis/reactive/test/GlitchFreeTest.ml index 5eea3073c22..1b991fc78a2 100644 --- a/analysis/reactive/test/GlitchFreeTest.ml +++ b/analysis/reactive/test/GlitchFreeTest.ml @@ -49,21 +49,23 @@ let test_same_source_anti_join () = let refs = FlatMap.create ~name:"refs" src - ~f:(fun _file data emit -> + ~f:(fun _file data wave -> let data : file_data = Stable.to_linear_value data in List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) data.refs) () in let decls = FlatMap.create ~name:"decls" src - ~f:(fun _file data emit -> + ~f:(fun _file data wave -> let data : file_data = Stable.to_linear_value data in List.iter - (fun pos -> emit (Stable.unsafe_of_value pos) Stable.unit) + (fun pos -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit) data.decl_positions) () in @@ -71,9 +73,12 @@ let test_same_source_anti_join () = let external_refs = Join.create ~name:"external_refs" refs decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_mb emit -> - if not (Maybe.is_some decl_mb) then emit 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 @@ -103,12 +108,13 @@ let test_multi_level_union () = (* refs1: level 1 *) let refs1 = FlatMap.create ~name:"refs1" src - ~f:(fun _file data emit -> + ~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 - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) data.refs) () in @@ -116,28 +122,32 @@ let test_multi_level_union () = (* intermediate: level 1 *) let intermediate = FlatMap.create ~name:"intermediate" src - ~f:(fun _file data emit -> + ~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 - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) data.refs) () in (* refs2: level 2 *) let refs2 = - FlatMap.create ~name:"refs2" intermediate ~f:(fun k v emit -> emit k v) () + FlatMap.create ~name:"refs2" intermediate + ~f:(fun k v wave -> StableWave.push wave k v) + () in (* decls: level 1 *) let decls = FlatMap.create ~name:"decls" src - ~f:(fun _file data emit -> + ~f:(fun _file data wave -> let data : file_data = Stable.to_linear_value data in List.iter - (fun pos -> emit (Stable.unsafe_of_value pos) Stable.unit) + (fun pos -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit) data.decl_positions) () in @@ -149,9 +159,12 @@ let test_multi_level_union () = let external_refs = Join.create ~name:"external_refs" all_refs decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_mb emit -> - if not (Maybe.is_some decl_mb) then emit 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 @@ -178,10 +191,11 @@ let test_real_pipeline_simulation () = (* decls: level 1 *) let decls = FlatMap.create ~name:"decls" src - ~f:(fun _file data emit -> + ~f:(fun _file data wave -> let data : full_file_data = Stable.to_linear_value data in List.iter - (fun pos -> emit (Stable.unsafe_of_value pos) Stable.unit) + (fun pos -> + StableWave.push wave (Stable.unsafe_of_value pos) Stable.unit) data.full_decls) () in @@ -189,11 +203,12 @@ let test_real_pipeline_simulation () = (* merged_value_refs: level 1 *) let merged_value_refs = FlatMap.create ~name:"merged_value_refs" src - ~f:(fun _file data emit -> + ~f:(fun _file data wave -> let data : full_file_data = Stable.to_linear_value data in List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) data.value_refs) () in @@ -201,11 +216,12 @@ let test_real_pipeline_simulation () = (* exception_refs_raw: level 1 *) let exception_refs_raw = FlatMap.create ~name:"exception_refs_raw" src - ~f:(fun _file data emit -> + ~f:(fun _file data wave -> let data : full_file_data = Stable.to_linear_value data in List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value v)) + StableWave.push wave (Stable.unsafe_of_value k) + (Stable.unsafe_of_value v)) data.exception_refs) () in @@ -213,9 +229,10 @@ let test_real_pipeline_simulation () = (* exception_decls: level 2 *) let exception_decls = FlatMap.create ~name:"exception_decls" decls - ~f:(fun pos _unit emit -> + ~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 emit pos Stable.unit) + if String.length pos_v > 0 && pos_v.[0] = 'E' then + StableWave.push wave pos Stable.unit) () in @@ -224,15 +241,15 @@ let test_real_pipeline_simulation () = Join.create ~name:"resolved_exception_refs" exception_refs_raw exception_decls ~key_of:(fun path _loc -> path) - ~f:(fun path loc decl_mb emit -> - if Maybe.is_some decl_mb then emit path loc) + ~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.create ~name:"resolved_refs_from" resolved_exception_refs - ~f:(fun posTo posFrom emit -> emit posFrom posTo) + ~f:(fun posTo posFrom wave -> StableWave.push wave posFrom posTo) () in @@ -245,9 +262,12 @@ let test_real_pipeline_simulation () = let external_value_refs = Join.create ~name:"external_value_refs" value_refs_from decls ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_mb emit -> - if not (Maybe.is_some decl_mb) then emit 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 @@ -277,9 +297,12 @@ let test_separate_sources () = let external_refs = Join.create ~name:"external_refs" refs_src decls_src ~key_of:(fun posFrom _posTo -> posFrom) - ~f:(fun _posFrom posTo decl_mb emit -> - if not (Maybe.is_some decl_mb) then emit 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 diff --git a/analysis/reactive/test/IntegrationTest.ml b/analysis/reactive/test/IntegrationTest.ml index 100bfe1f277..b90dd28bd17 100644 --- a/analysis/reactive/test/IntegrationTest.ml +++ b/analysis/reactive/test/IntegrationTest.ml @@ -16,9 +16,10 @@ let test_file_collection () = (* First flatMap: aggregate word counts across files with merge *) let word_counts = FlatMap.create ~name:"word_counts" files - ~f:(fun _path counts emit -> + ~f:(fun _path counts wave -> StringMap.iter - (fun k v -> emit (Stable.unsafe_of_value k) (Stable.int v)) + (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:(fun a b -> @@ -30,8 +31,9 @@ let test_file_collection () = (* Second flatMap: filter to words with count >= 2 *) let frequent_words = FlatMap.create ~name:"frequent_words" word_counts - ~f:(fun word count emit -> - if Stable.to_linear_value count >= 2 then emit word count) + ~f:(fun word count wave -> + if Stable.to_linear_value count >= 2 then + StableWave.push wave word count) () in diff --git a/analysis/reactive/test/JoinTest.ml b/analysis/reactive/test/JoinTest.ml index c3ba233bb7f..2732e6863fa 100644 --- a/analysis/reactive/test/JoinTest.ml +++ b/analysis/reactive/test/JoinTest.ml @@ -17,9 +17,12 @@ let test_join () = let joined = Join.create ~name:"joined" left right ~key_of:(fun path _loc_from -> path) - ~f:(fun _path loc_from decl_pos_mb emit -> + ~f:(fun _path loc_from decl_pos_mb wave -> if Maybe.is_some decl_pos_mb then - emit (Maybe.unsafe_get decl_pos_mb) loc_from) + let decl_pos = + Stable.to_linear_value (Maybe.unsafe_get decl_pos_mb) + in + StableWave.push wave (Stable.int decl_pos) loc_from) () in @@ -83,9 +86,12 @@ let test_join_with_merge () = let joined = Join.create ~name:"joined" left right ~key_of:(fun _id path -> path) (* Look up by path *) - ~f:(fun _id _path value_mb emit -> - if Maybe.is_some value_mb then emit 0 (Maybe.unsafe_get value_mb)) - ~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 diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index d6426c79851..f2a4b399997 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -138,12 +138,12 @@ let to_file_data_collection (collection : t) : (string, DceFileProcessing.file_data option) Reactive.t = Reactive.FlatMap.create ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) - ~f:(fun path result_opt emit -> + ~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; _} -> - emit path (Stable.unsafe_of_value (Some data)) - | _ -> emit path (Stable.unsafe_of_value None)) + StableWave.push wave path (Stable.unsafe_of_value (Some data)) + | _ -> StableWave.push wave path (Stable.unsafe_of_value None)) () (** Iterate over all file_data in the collection *) diff --git a/analysis/reanalyze/src/ReactiveDeclRefs.ml b/analysis/reanalyze/src/ReactiveDeclRefs.ml index 8ee5c7a1ef5..73644c90592 100644 --- a/analysis/reanalyze/src/ReactiveDeclRefs.ml +++ b/analysis/reanalyze/src/ReactiveDeclRefs.ml @@ -15,10 +15,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Group declarations by file *) let decls_by_file : (string, (Lexing.position * Decl.t) list) Reactive.t = Reactive.FlatMap.create ~name:"decl_refs.decls_by_file" decls - ~f:(fun pos decl emit -> + ~f:(fun pos decl wave -> let pos = Stable.to_linear_value pos in let decl = Stable.to_linear_value decl in - emit + StableWave.push wave (Stable.unsafe_of_value pos.Lexing.pos_fname) (Stable.unsafe_of_value [(pos, decl)])) ~merge:(fun a b -> @@ -38,29 +38,51 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let value_decl_refs : (Lexing.position, PosSet.t) Reactive.t = 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_mb emit -> + ~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 = Maybe.unsafe_get decls_mb in + 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 emit decl_pos targets) + 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:PosSet.union () + ~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.create ~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_mb emit -> + ~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 = Maybe.unsafe_get decls_mb in + 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 emit decl_pos targets) + 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:PosSet.union () + ~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. @@ -68,34 +90,47 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let with_value_refs : (Lexing.position, PosSet.t) Reactive.t = Reactive.Join.create ~name:"decl_refs.with_value_refs" decls value_decl_refs ~key_of:(fun pos _decl -> pos) - ~f:(fun pos _decl refs_mb emit -> + ~f:(fun pos _decl refs_mb wave -> + let pos = Stable.to_linear_value pos in let refs = - if Maybe.is_some refs_mb then Maybe.unsafe_get refs_mb + if Maybe.is_some refs_mb then + Stable.to_linear_value (Maybe.unsafe_get refs_mb) else PosSet.empty in - emit pos refs) + 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.create ~name:"decl_refs.with_type_refs" decls type_decl_refs ~key_of:(fun pos _decl -> pos) - ~f:(fun pos _decl refs_mb emit -> + ~f:(fun pos _decl refs_mb wave -> + let pos = Stable.to_linear_value pos in let refs = - if Maybe.is_some refs_mb then Maybe.unsafe_get refs_mb + if Maybe.is_some refs_mb then + Stable.to_linear_value (Maybe.unsafe_get refs_mb) else PosSet.empty in - emit pos refs) + StableWave.push wave + (Stable.unsafe_of_value pos) + (Stable.unsafe_of_value refs)) () in (* Combine into final (value_targets, type_targets) pairs *) 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_mb emit -> + ~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 Maybe.unsafe_get type_targets_mb + if Maybe.is_some type_targets_mb then + Stable.to_linear_value (Maybe.unsafe_get type_targets_mb) else PosSet.empty in - emit pos (value_targets, type_targets)) + 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 ad3d3538fb9..5d8fcf8b6d3 100644 --- a/analysis/reanalyze/src/ReactiveExceptionRefs.ml +++ b/analysis/reanalyze/src/ReactiveExceptionRefs.ml @@ -27,7 +27,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 1: Index exception declarations by path *) let exception_decls = Reactive.FlatMap.create ~name:"exc_refs.exception_decls" decls - ~f:(fun _pos decl emit -> + ~f:(fun _pos decl wave -> let decl : Decl.t = Stable.to_linear_value decl in match decl.Decl.declKind with | Exception -> @@ -38,7 +38,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) loc_ghost = false; } in - emit (Stable.unsafe_of_value decl.path) (Stable.unsafe_of_value 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 @@ -48,24 +50,30 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) 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_mb emit -> + ~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 = Maybe.unsafe_get loc_to_mb in + let loc_to = Stable.to_linear_value (Maybe.unsafe_get loc_to_mb) in (* Add value reference: pos_to -> pos_from (refs_to direction) *) - emit loc_to.Location.loc_start - (PosSet.singleton loc_from.Location.loc_start)) - ~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.create ~name:"exc_refs.resolved_refs_from" resolved_refs - ~f:(fun posTo posFromSet emit -> + ~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 -> - emit + StableWave.push wave (Stable.unsafe_of_value posFrom) (Stable.unsafe_of_value (PosSet.singleton posTo))) posFromSet) diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 1fdc4cfa150..28fd4590afb 100644 --- a/analysis/reanalyze/src/ReactiveLiveness.ml +++ b/analysis/reanalyze/src/ReactiveLiveness.ml @@ -45,11 +45,11 @@ let create ~(merged : ReactiveMerge.t) : t = (* Step 2: Convert to edges format for fixpoint: decl -> successor list *) let edges : (Lexing.position, Lexing.position StableList.inner) Reactive.t = Reactive.FlatMap.create ~name:"liveness.edges" decl_refs_index - ~f:(fun pos v emit -> + ~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 - emit + StableWave.push wave (Stable.unsafe_of_value pos) (Stable.unsafe_of_value (StableList.unsafe_inner_of_list (PosSet.elements all_targets)))) @@ -71,11 +71,14 @@ let create ~(merged : ReactiveMerge.t) : t = Reactive.Join.create ~name:"liveness.external_value_refs" value_refs_from decls ~key_of:(fun posFrom _targets -> posFrom) - ~f:(fun _posFrom targets decl_mb emit -> + ~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.iter (fun posTo -> emit 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 @@ -83,11 +86,14 @@ let create ~(merged : ReactiveMerge.t) : t = Reactive.Join.create ~name:"liveness.external_type_refs" type_refs_from decls ~key_of:(fun posFrom _targets -> posFrom) - ~f:(fun _posFrom targets decl_mb emit -> + ~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.iter (fun posTo -> emit 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 @@ -102,12 +108,14 @@ let create ~(merged : ReactiveMerge.t) : t = let annotated_roots : (Lexing.position, unit) Reactive.t = Reactive.Join.create ~name:"liveness.annotated_roots" decls annotations ~key_of:(fun pos _decl -> pos) - ~f:(fun pos _decl ann_mb emit -> + ~f:(fun pos _decl ann_mb wave -> + let pos = Stable.to_linear_value pos in if Maybe.is_some ann_mb then - match Maybe.unsafe_get ann_mb with - | FileAnnotations.Live | FileAnnotations.GenType -> emit pos () + 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 () () -> ()) + ~merge:(fun _ _ -> Stable.unit) () in diff --git a/analysis/reanalyze/src/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index e3857602ff4..b4e15905455 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -26,21 +26,22 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Declarations: (pos, Decl.t) with last-write-wins *) let decls = Reactive.FlatMap.create ~name:"decls" source - ~f:(fun _path file_data_opt emit -> + ~f:(fun _path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> Declarations.builder_to_list file_data.DceFileProcessing.decls |> List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value 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.create ~name:"annotations" source - ~f:(fun _path file_data_opt emit -> + ~f:(fun _path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () @@ -48,14 +49,15 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : FileAnnotations.builder_to_list file_data.DceFileProcessing.annotations |> List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value 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.create ~name:"value_refs_from" source - ~f:(fun _path file_data_opt emit -> + ~f:(fun _path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () @@ -63,7 +65,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : References.builder_value_refs_from_list file_data.DceFileProcessing.refs |> List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value 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))) @@ -73,7 +76,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Type refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let type_refs_from = Reactive.FlatMap.create ~name:"type_refs_from" source - ~f:(fun _path file_data_opt emit -> + ~f:(fun _path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () @@ -81,7 +84,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : References.builder_type_refs_from_list file_data.DceFileProcessing.refs |> List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value 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))) @@ -91,7 +95,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Cross-file items: (path, CrossFileItems.t) with merge by concatenation *) let cross_file_items = Reactive.FlatMap.create ~name:"cross_file_items" source - ~f:(fun path file_data_opt emit -> + ~f:(fun path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () @@ -99,7 +103,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : let items = CrossFileItems.builder_to_t file_data.DceFileProcessing.cross_file in - emit path (Stable.unsafe_of_value items)) + StableWave.push wave path (Stable.unsafe_of_value items)) ~merge:(fun a b -> let a = Stable.to_linear_value a in let b = Stable.to_linear_value b in @@ -116,14 +120,15 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* File deps map: (from_file, FileSet of to_files) with FileSet.union merge *) let file_deps_map = Reactive.FlatMap.create ~name:"file_deps_map" source - ~f:(fun _path file_data_opt emit -> + ~f:(fun _path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () | Some file_data -> FileDeps.builder_deps_to_list file_data.DceFileProcessing.file_deps |> List.iter (fun (k, v) -> - emit (Stable.unsafe_of_value k) (Stable.unsafe_of_value 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))) @@ -133,7 +138,7 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Files set: (source_path, ()) - just track which source files exist *) let files = Reactive.FlatMap.create ~name:"files" source - ~f:(fun _cmt_path file_data_opt emit -> + ~f:(fun _cmt_path file_data_opt wave -> let file_data_opt = Stable.to_linear_value file_data_opt in match file_data_opt with | None -> () @@ -143,7 +148,8 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : in FileSet.iter (fun f -> - emit (Stable.unsafe_of_value f) (Stable.unsafe_of_value ())) + StableWave.push wave (Stable.unsafe_of_value f) + (Stable.unsafe_of_value ())) file_set) () in @@ -151,11 +157,11 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Extract exception_refs from cross_file_items for ReactiveExceptionRefs *) let exception_refs_collection = Reactive.FlatMap.create ~name:"exception_refs_collection" cross_file_items - ~f:(fun _path items emit -> + ~f:(fun _path items wave -> let items = Stable.to_linear_value items in items.CrossFileItems.exception_refs |> List.iter (fun (r : CrossFileItems.exception_ref) -> - emit + StableWave.push wave (Stable.unsafe_of_value r.exception_path) (Stable.unsafe_of_value r.loc_from))) () diff --git a/analysis/reanalyze/src/ReactiveSolver.ml b/analysis/reanalyze/src/ReactiveSolver.ml index 58ae53e84b6..54841c2cc1b 100644 --- a/analysis/reanalyze/src/ReactiveSolver.ml +++ b/analysis/reanalyze/src/ReactiveSolver.ml @@ -57,8 +57,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let dead_decls = Reactive.Join.create ~name:"solver.dead_decls" decls live ~key_of:(fun pos _decl -> pos) - ~f:(fun pos decl live_mb emit -> - if not (Maybe.is_some live_mb) then emit pos decl) + ~f:(fun pos decl live_mb wave -> + if not (Maybe.is_some live_mb) then StableWave.push wave pos decl) () in @@ -66,8 +66,8 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let live_decls = Reactive.Join.create ~name:"solver.live_decls" decls live ~key_of:(fun pos _decl -> pos) - ~f:(fun pos decl live_mb emit -> - if Maybe.is_some live_mb then emit pos decl) + ~f:(fun pos decl live_mb wave -> + if Maybe.is_some live_mb then StableWave.push wave pos decl) () in @@ -76,15 +76,15 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) if not config.DceConfig.run.transitive then (* Dead modules only reported in transitive mode *) Reactive.FlatMap.create ~name:"solver.dead_modules_empty" dead_decls - ~f:(fun _k _v _emit -> ()) + ~f:(fun _k _v _wave -> ()) () else (* modules_with_dead: (moduleName, (loc, fileName)) for each module with dead decls *) let modules_with_dead = Reactive.FlatMap.create ~name:"solver.modules_with_dead" dead_decls - ~f:(fun _pos decl emit -> + ~f:(fun _pos decl wave -> let decl = Stable.to_linear_value decl in - emit + StableWave.push wave (Stable.unsafe_of_value (decl_module_name decl)) (Stable.unsafe_of_value (decl.moduleLoc, decl.pos.Lexing.pos_fname))) @@ -94,9 +94,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* modules_with_live: (moduleName, ()) for each module with live decls *) let modules_with_live = Reactive.FlatMap.create ~name:"solver.modules_with_live" live_decls - ~f:(fun _pos decl emit -> + ~f:(fun _pos decl wave -> let decl = Stable.to_linear_value decl in - emit + StableWave.push wave (Stable.unsafe_of_value (decl_module_name decl)) (Stable.unsafe_of_value ())) () @@ -104,9 +104,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Anti-join: modules in dead but not in live *) 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_mb emit -> - if not (Maybe.is_some live_mb) then emit modName (loc, fileName) + ~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 @@ -114,9 +114,9 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Reactive per-file grouping of dead declarations *) let dead_decls_by_file = Reactive.FlatMap.create ~name:"solver.dead_decls_by_file" dead_decls - ~f:(fun _pos decl emit -> + ~f:(fun _pos decl wave -> let decl = Stable.to_linear_value decl in - emit + StableWave.push wave (Stable.unsafe_of_value decl.pos.Lexing.pos_fname) (Stable.unsafe_of_value [decl])) ~merge:(fun decls1 decls2 -> @@ -182,10 +182,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) match (transitive, value_refs_from) with | true, _ | false, None -> Reactive.FlatMap.create ~name:"solver.issues_by_file" dead_decls_by_file - ~f:(fun file decls emit -> + ~f:(fun file decls wave -> let file = Stable.to_linear_value file in let decls = Stable.to_linear_value decls in - emit + StableWave.push wave (Stable.unsafe_of_value file) (Stable.unsafe_of_value (issues_for_file file decls))) () @@ -194,16 +194,22 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) and join every file against it so per-file issues recompute. *) let refs_token = Reactive.FlatMap.create ~name:"solver.refs_token" refs_from - ~f:(fun _posFrom _targets emit -> - emit (Stable.unsafe_of_value ()) (Stable.unsafe_of_value ())) + ~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.create ~name:"solver.issues_by_file" dead_decls_by_file refs_token - ~key_of:(fun _file _decls -> ()) - ~f:(fun file decls _token_mb emit -> - emit file (issues_for_file file decls)) + ~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 @@ -212,10 +218,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Reactive.Join.create ~name:"solver.incorrect_dead_decls" live_decls annotations ~key_of:(fun pos _decl -> pos) - ~f:(fun pos decl ann_mb emit -> + ~f:(fun pos decl ann_mb wave -> if Maybe.is_some ann_mb then - match Maybe.unsafe_get ann_mb with - | FileAnnotations.Dead -> emit pos decl + match Stable.to_linear_value (Maybe.unsafe_get ann_mb) with + | FileAnnotations.Dead -> StableWave.push wave pos decl | _ -> ()) () in @@ -223,10 +229,12 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Reactive modules_with_reported: modules that have at least one reported dead value *) let modules_with_reported = Reactive.FlatMap.create ~name:"solver.modules_with_reported" issues_by_file - ~f:(fun _file v emit -> + ~f:(fun _file v wave -> let _issues, modules_list = Stable.to_linear_value v in List.iter - (fun m -> emit (Stable.unsafe_of_value m) (Stable.unsafe_of_value ())) + (fun m -> + StableWave.push wave (Stable.unsafe_of_value m) + (Stable.unsafe_of_value ())) modules_list) () in @@ -235,8 +243,10 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let dead_module_issues = 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_mb emit -> + ~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 @@ -251,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 - emit moduleName - (AnalysisResult.make_dead_module_issue ~loc ~moduleName)) + StableWave.push wave + (Stable.unsafe_of_value moduleName) + (Stable.unsafe_of_value + (AnalysisResult.make_dead_module_issue ~loc ~moduleName))) () in diff --git a/analysis/reanalyze/src/ReactiveTypeDeps.ml b/analysis/reanalyze/src/ReactiveTypeDeps.ml index 922d74d650c..156efd99207 100644 --- a/analysis/reanalyze/src/ReactiveTypeDeps.ml +++ b/analysis/reanalyze/src/ReactiveTypeDeps.ml @@ -50,11 +50,11 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 1: Index decls by path *) let decl_by_path = Reactive.FlatMap.create ~name:"type_deps.decl_by_path" decls - ~f:(fun _pos decl emit -> + ~f:(fun _pos decl wave -> let decl = Stable.to_linear_value decl in match decl_to_info decl with | Some info -> - emit + StableWave.push wave (Stable.unsafe_of_value info.path) (Stable.unsafe_of_value [info]) | None -> ()) @@ -67,18 +67,18 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Step 2: Same-path refs - connect all decls at the same path *) let same_path_refs = Reactive.FlatMap.create ~name:"type_deps.same_path_refs" decl_by_path - ~f:(fun _path decls emit -> + ~f:(fun _path decls wave -> let decls = Stable.to_linear_value decls in match decls with | [] | [_] -> () | first :: rest -> rest |> List.iter (fun other -> - emit + 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 - emit + StableWave.push wave (Stable.unsafe_of_value first.pos) (Stable.unsafe_of_value (PosSet.singleton other.pos)))) ~merge:(fun a b -> @@ -91,7 +91,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* First, extract impl decls that need to look up intf *) let impl_decls = Reactive.FlatMap.create ~name:"type_deps.impl_decls" decls - ~f:(fun _pos decl emit -> + ~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 -> ( @@ -102,7 +102,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let path_2 = path_1 |> DcePath.typeToInterface in let intf_path1 = typeLabelName :: path_1 in let intf_path2 = typeLabelName :: path_2 in - emit + StableWave.push wave (Stable.unsafe_of_value info.pos) (Stable.unsafe_of_value (info, intf_path1, intf_path2))) | _ -> ()) @@ -115,51 +115,78 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let impl_to_intf_refs = Reactive.Join.create ~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_mb emit -> + ~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 Maybe.unsafe_get intf_decls_mb with + match Stable.to_linear_value (Maybe.unsafe_get intf_decls_mb) with | intf_info :: _ -> (* Found at path1: posTo=impl, posFrom=intf *) - emit info.pos (PosSet.singleton intf_info.pos); + 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 *) - emit intf_info.pos (PosSet.singleton info.pos) + StableWave.push wave + (Stable.unsafe_of_value intf_info.pos) + (Stable.unsafe_of_value (PosSet.singleton info.pos)) | [] -> ()) - ~merge:PosSet.union () + ~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.create ~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_mb emit -> + ~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 Maybe.unsafe_get intf_decls_mb with + match Stable.to_linear_value (Maybe.unsafe_get intf_decls_mb) with | _ :: _ -> true | [] -> false in - if not found then emit pos (info, intf_path2)) + 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.create ~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_mb emit -> + ~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 Maybe.unsafe_get intf_decls_mb with + match Stable.to_linear_value (Maybe.unsafe_get intf_decls_mb) with | intf_info :: _ -> (* posTo=impl, posFrom=intf *) - emit info.pos (PosSet.singleton intf_info.pos); + 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 - emit intf_info.pos (PosSet.singleton info.pos) + StableWave.push wave + (Stable.unsafe_of_value intf_info.pos) + (Stable.unsafe_of_value (PosSet.singleton info.pos)) | [] -> ()) - ~merge:PosSet.union () + ~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. @@ -169,7 +196,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) and the lookup is for finding the impl. *) let intf_decls = Reactive.FlatMap.create ~name:"type_deps.intf_decls" decls - ~f:(fun _pos decl emit -> + ~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 -> ( @@ -179,7 +206,7 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let impl_path = typeLabelName :: DcePath.moduleToImplementation pathToType in - emit + StableWave.push wave (Stable.unsafe_of_value info.pos) (Stable.unsafe_of_value (info, impl_path))) | _ -> ()) @@ -189,10 +216,13 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) let intf_to_impl_refs = Reactive.Join.create ~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_mb emit -> + ~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 Maybe.unsafe_get impl_decls_mb with + 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: @@ -208,11 +238,18 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) Here loc is the current intf decl, loc1 is the found impl. So extendTypeDependencies loc1 loc means posTo=loc1=impl, posFrom=loc=intf *) - emit impl_info.pos (PosSet.singleton intf_info.pos); + 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 - emit intf_info.pos (PosSet.singleton impl_info.pos) + StableWave.push wave + (Stable.unsafe_of_value intf_info.pos) + (Stable.unsafe_of_value (PosSet.singleton impl_info.pos)) | [] -> ()) - ~merge:PosSet.union () + ~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: @@ -257,12 +294,12 @@ let create ~(decls : (Lexing.position, Decl.t) Reactive.t) (* Invert the combined refs_to to refs_from *) Reactive.FlatMap.create ~name:"type_deps.all_type_refs_from" combined_refs_to - ~f:(fun posTo posFromSet emit -> + ~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 -> - emit + StableWave.push wave (Stable.unsafe_of_value posFrom) (Stable.unsafe_of_value (PosSet.singleton posTo))) posFromSet) From d9ea44e42f811a8405e3ab348cc51469ed232523 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 8 Mar 2026 21:32:37 +0100 Subject: [PATCH 44/54] analysis/reactive: assert zero allocation and zero stable leak in alloc tests Add assert (words = 0) after each allocation measurement and assert (Allocator.live_block_count () = 0) after teardown to catch regressions in both GC allocation and stable storage leaks. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/test/AllocTest.ml | 32 +++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 937882857d3..4f476f1e3e6 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -83,9 +83,11 @@ let test_fixpoint_alloc () = List.iter (fun n -> let words = test_fixpoint_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + assert (words = 0)) [10; 100; 1000]; print_stable_usage (); + assert (Allocator.live_block_count () = 0); Printf.printf "PASSED\n\n" (* ---- FlatMap allocation ---- *) @@ -144,9 +146,11 @@ let test_flatmap_alloc () = List.iter (fun n -> let words = test_flatmap_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + assert (words = 0)) [10; 100; 1000]; print_stable_usage (); + assert (Allocator.live_block_count () = 0); Printf.printf "PASSED\n\n" (* ---- Union allocation ---- *) @@ -201,9 +205,11 @@ let test_union_alloc () = List.iter (fun n -> let words = test_union_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + assert (words = 0)) [10; 100; 1000]; print_stable_usage (); + assert (Allocator.live_block_count () = 0); Printf.printf "PASSED\n\n" (* ---- Join allocation ---- *) @@ -280,9 +286,11 @@ let test_join_alloc () = List.iter (fun n -> let words = test_join_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + 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 ---- *) @@ -352,9 +360,11 @@ let test_reactive_join_alloc () = List.iter (fun n -> let words = test_reactive_join_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + 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 ---- *) @@ -416,9 +426,11 @@ let test_reactive_fixpoint_alloc () = List.iter (fun n -> let words = test_reactive_fixpoint_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + 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 ---- *) @@ -475,9 +487,11 @@ let test_reactive_union_alloc () = List.iter (fun n -> let words = test_reactive_union_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + 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 ---- *) @@ -536,9 +550,11 @@ let test_reactive_flatmap_alloc () = List.iter (fun n -> let words = test_reactive_flatmap_alloc_n n in - Printf.printf " n=%d: %d words/iter\n" n words) + Printf.printf " n=%d: %d words/iter\n" n words; + assert (words = 0)) [10; 100; 1000]; print_stable_usage (); + assert (Allocator.live_block_count () = 0); Printf.printf "PASSED\n\n" let run_all () = From 4e06ea6a6cb95e8f18d400e7e81bc19a94c52bbd Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 08:16:08 +0100 Subject: [PATCH 45/54] analysis/reactive: make StableList interface stable-safe and make ReactiveFixpoint nearly stable-safe MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit StableList iter/iter_with/exists/exists_with now provide 'a Stable.t to callbacks. This eliminates stable_key (unsafe_of_value) from all ReactiveFixpoint processing code — only 2 calls remain in debug-only Invariants. Use unsafe_to_nonlinear_value in Invariants where values are stored in Hashtbl/lists. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 205 +++++++++------------- analysis/reactive/src/StableList.ml | 10 +- analysis/reactive/src/StableList.mli | 8 +- 3 files changed, 97 insertions(+), 126 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 6c737fb1b33..2b736c430b5 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -47,23 +47,27 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = else if StableList.is_empty new_succs then false else let old_set = Hashtbl.create (StableList.length old_succs) in - StableList.iter (fun k -> Hashtbl.replace old_set k ()) old_succs; - StableList.exists (fun tgt -> not (Hashtbl.mem old_set tgt)) new_succs + StableList.iter + (fun k -> Hashtbl.replace old_set (Stable.unsafe_to_nonlinear_value k) ()) + old_succs; + StableList.exists + (fun tgt -> not (Hashtbl.mem old_set (Stable.to_linear_value tgt))) + new_succs let[@inline] stable_key k = Stable.unsafe_of_value k -let[@inline] enqueue q k = StableQueue.push q (stable_key k) +let[@inline] enqueue q k = StableQueue.push q k (* 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_root visited frontier _t k () = - StableSet.add visited (stable_key k); - enqueue frontier k + StableSet.add visited k; + StableQueue.push frontier k let bfs_visit_succ visited frontier succ = - if not (StableSet.mem visited (stable_key succ)) then ( - StableSet.add visited (stable_key succ); - enqueue 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; @@ -72,8 +76,7 @@ let compute_reachable ~visited t = let node_work = ref 0 in let edge_work = ref 0 in StableSet.iter_with - (fun (visited, frontier) k -> - bfs_seed_root visited frontier t (Stable.to_linear_value k) ()) + (fun (visited, frontier) k -> bfs_seed_root visited frontier t k ()) (visited, frontier) t.roots; while not (StableQueue.is_empty frontier) do let k = StableQueue.pop frontier in @@ -230,7 +233,7 @@ module Invariants = struct let copy_set_to_hashtbl (s : 'k StableSet.t) = let out = Hashtbl.create (StableSet.cardinal s) in StableSet.iter_with - (fun out k -> Hashtbl.replace out (Stable.to_linear_value k) ()) + (fun out k -> Hashtbl.replace out (Stable.unsafe_to_nonlinear_value k) ()) out s; out @@ -248,26 +251,24 @@ module Invariants = struct (* Drain and re-push to iterate without consuming *) let items = ref [] in while not (StableQueue.is_empty edge_change_queue) do - let src = Stable.to_linear_value (StableQueue.pop edge_change_queue) in + let src = StableQueue.pop edge_change_queue in items := src :: !items; - enqueue q_copy src + StableQueue.push q_copy src done; (* Restore queue *) - List.iter (fun src -> enqueue edge_change_queue src) (List.rev !items); + List.iter + (fun src -> StableQueue.push edge_change_queue src) + (List.rev !items); StableQueue.destroy q_copy; (* Check each *) List.iter (fun src -> - let r_old = - StableMap.find_maybe old_successors_for_changed (stable_key src) - in + let r_old = StableMap.find_maybe old_successors_for_changed src in let old_succs = if Maybe.is_some r_old then Maybe.unsafe_get r_old else StableList.empty () in - let r_new = - StableMap.find_maybe new_successors_for_changed (stable_key src) - in + let r_new = StableMap.find_maybe new_successors_for_changed src in let new_succs = if Maybe.is_some r_new then Maybe.unsafe_get r_new else StableList.empty () @@ -275,27 +276,25 @@ module Invariants = struct let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs in - let actual_has_new = StableSet.mem edge_has_new (stable_key src) in + let actual_has_new = StableSet.mem edge_has_new src in assert_ (expected_has_new = actual_has_new) "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") !items) let assert_deleted_nodes_closed ~current ~deleted_nodes - ~(old_successors : 'k -> 'k StableList.t) = + ~(old_successors : 'k Stable.t -> 'k StableList.t) = if enabled then StableSet.iter_with (fun () k -> - let k = Stable.to_linear_value k in - assert_ - (StableSet.mem current (stable_key k)) + assert_ (StableSet.mem current k) "ReactiveFixpoint.apply invariant failed: deleted node not in \ current"; StableList.iter (fun succ -> - if StableSet.mem current (stable_key succ) then + if StableSet.mem current succ then assert_ - (StableSet.mem deleted_nodes (stable_key succ)) + (StableSet.mem deleted_nodes succ) "ReactiveFixpoint.apply invariant failed: deleted closure \ broken") (old_successors k)) @@ -305,8 +304,7 @@ module Invariants = struct if enabled then StableSet.iter_with (fun () k -> - let k = Stable.to_linear_value k in - if not (StableSet.mem current (stable_key k)) then + if not (StableSet.mem current k) then assert_ (not (supported k)) "ReactiveFixpoint.apply invariant failed: supported deleted node \ @@ -330,9 +328,8 @@ module Invariants = struct let expected = Hashtbl.create (StableSet.cardinal deleted_nodes) in StableSet.iter_with (fun expected k -> - let k = Stable.to_linear_value k in - if not (StableSet.mem current (stable_key k)) then - Hashtbl.replace expected k ()) + if not (StableSet.mem current k) then + Hashtbl.replace expected (Stable.unsafe_to_nonlinear_value k) ()) expected deleted_nodes; let actual = Hashtbl.create (List.length output_entries) in List.iter @@ -357,9 +354,9 @@ module Invariants = struct let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in StableSet.iter_with (fun expected_adds k -> - let k = Stable.to_linear_value k in - if not (Hashtbl.mem pre_current k) then - Hashtbl.replace expected_adds k ()) + let k_raw = Stable.unsafe_to_nonlinear_value k in + if not (Hashtbl.mem pre_current k_raw) then + Hashtbl.replace expected_adds k_raw ()) expected_adds t.current; Hashtbl.iter (fun k () -> @@ -467,57 +464,51 @@ 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 (stable_key target) (stable_key pred) +let add_pred t ~target ~pred = StableMapSet.add t.pred_map target pred let remove_pred t ~target ~pred = - StableMapSet.remove_from_set_and_recycle_if_empty t.pred_map - (stable_key target) (stable_key pred) + StableMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred 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 (stable_key k) t has_live_pred_key + StableMapSet.exists_inner_with t.pred_map k t has_live_pred_key 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 r = StableMap.find_maybe t.edge_map (stable_key src) in + let r = StableMap.find_maybe t.edge_map src in let old_successors = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in if StableList.is_empty old_successors && StableList.is_empty new_successors - then StableMap.remove t.edge_map (stable_key src) + 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 (stable_key src) new_successors) + StableMap.replace t.edge_map src 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 (stable_key src)) + 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 (stable_key k)) - new_successors; - StableList.iter - (fun k -> StableSet.add t.scratch_set_b (stable_key k)) - old_successors; + 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 (stable_key target)) then + 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 (stable_key target)) then + if not (StableSet.mem t.scratch_set_b target) then add_pred t ~target ~pred:src) () new_successors; - StableMap.replace t.edge_map (stable_key src) new_successors) + StableMap.replace t.edge_map src new_successors) let initialize t ~roots ~edges = StableSet.clear t.roots; @@ -525,65 +516,56 @@ let initialize t ~roots ~edges = 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:(Stable.to_linear_value k) - ~new_successors:successors); + apply_edge_update t ~src:k ~new_successors:successors); recompute_current t -let is_supported t k = - StableSet.mem t.roots (stable_key k) || has_live_predecessor t k +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 (stable_key k) in + let r = StableMap.find_maybe t.old_successors_for_changed k in if Maybe.is_some r then Maybe.unsafe_get r else - let r2 = StableMap.find_maybe t.edge_map (stable_key k) in + let r2 = StableMap.find_maybe t.edge_map k in if Maybe.is_some r2 then Maybe.unsafe_get r2 else StableList.empty () let mark_deleted t k = - if - StableSet.mem t.current (stable_key k) - && not (StableSet.mem t.deleted_nodes (stable_key k)) - then ( - StableSet.add t.deleted_nodes (stable_key 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 (stable_key k) - && not (StableSet.mem t.expansion_seen (stable_key k)) - then ( - StableSet.add t.expansion_seen (stable_key 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 (stable_key k)) then ( - StableSet.add t.current (stable_key k); - if not (StableSet.mem t.deleted_nodes (stable_key k)) then - StableWave.push t.output_wave (Stable.unsafe_of_value k) - (Maybe.to_stable (Maybe.some Stable.unit)); + 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 (stable_key k) - && (not (StableSet.mem t.current (stable_key k))) - && (not (StableSet.mem t.rederive_pending (stable_key k))) + 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 (stable_key k); + 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 (stable_key k) in + 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 set_add_k set k = StableSet.add set (stable_key k) +let set_add_k set k = StableSet.add set k let mark_deleted_if_absent (t, set) k = - if not (StableSet.mem set (stable_key k)) then mark_deleted t k + if not (StableSet.mem set k) then mark_deleted t k -let not_in_set set k = not (StableSet.mem set (stable_key k)) +let not_in_set set k = not (StableSet.mem set k) let mark_deleted_unless_in_set t set xs = StableList.iter_with mark_deleted_if_absent (t, set) xs @@ -591,21 +573,20 @@ let mark_deleted_unless_in_set 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 r = StableMap.find_maybe t.edge_map (stable_key src) in + let r = StableMap.find_maybe t.edge_map src in let old_succs = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in let new_succs = if Maybe.is_some mv then Maybe.unsafe_get mv else StableList.empty () in - StableMap.replace t.old_successors_for_changed (stable_key src) old_succs; - StableMap.replace t.new_successors_for_changed (stable_key src) new_succs; + StableMap.replace t.old_successors_for_changed src old_succs; + StableMap.replace t.new_successors_for_changed src new_succs; enqueue t.edge_change_queue src; - let src_is_live = StableSet.mem t.current (stable_key src) in + 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 (stable_key src) + | _ 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 | _ -> @@ -615,15 +596,15 @@ let scan_edge_entry t src mv = 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 (stable_key src) + StableSet.add t.edge_has_new src let apply_root_mutation t k mv = - if Maybe.is_some mv then StableSet.add t.roots (stable_key k) - else StableSet.remove t.roots (stable_key k) + 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 (stable_key k)) then - StableWave.push t.output_wave (Stable.unsafe_of_value k) Maybe.none_stable + 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 @@ -651,21 +632,13 @@ let apply_list t ~roots ~edges = (* 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 (Stable.to_linear_value k) (Stable.to_linear_value mv)) + (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 -> - let mv = Stable.to_linear_value mv in - let mv = - if Maybe.is_some mv then - Maybe.some (Stable.unsafe_of_value (Maybe.unsafe_get mv)) - else Maybe.none - in - scan_edge_entry t (Stable.to_linear_value src) mv) + (fun t src mv -> scan_edge_entry t src (Maybe.of_stable mv)) t; Invariants.assert_edge_has_new_consistent @@ -676,7 +649,7 @@ let apply_list t ~roots ~edges = (* Phase 2: delete BFS *) while not (StableQueue.is_empty t.delete_queue) do - let k = Stable.to_linear_value (StableQueue.pop t.delete_queue) in + 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; @@ -689,9 +662,7 @@ let apply_list t ~roots ~edges = (* Phase 3: apply root and edge mutations *) StableWave.iter_with roots - (fun t k mv -> - apply_root_mutation t (Stable.to_linear_value k) - (Stable.to_linear_value mv)) + (fun t k mv -> apply_root_mutation t k (Stable.to_linear_value mv)) t; (* Apply edge updates by draining edge_change_queue. *) @@ -701,9 +672,7 @@ let apply_list t ~roots ~edges = let new_succs = if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () in - apply_edge_update t - ~src:(Stable.to_linear_value src) - ~new_successors:new_succs + 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 *) @@ -721,7 +690,7 @@ let apply_list t ~roots ~edges = StableSet.clear t.rederive_pending; StableSet.iter_with - (fun t k -> enqueue_rederive_if_needed_kv t (Stable.to_linear_value k)) + (fun t k -> enqueue_rederive_if_needed_kv t k) t t.deleted_nodes; while not (StableQueue.is_empty t.rederive_queue) do @@ -731,7 +700,7 @@ let apply_list t ~roots ~edges = if StableSet.mem t.deleted_nodes k && (not (StableSet.mem t.current k)) - && is_supported t (Stable.to_linear_value k) + && is_supported t k then ( StableSet.add t.current k; if Metrics.enabled then m.rederived_nodes <- m.rederived_nodes + 1; @@ -753,14 +722,14 @@ let apply_list t ~roots ~edges = (* Seed expansion from added roots *) while not (StableQueue.is_empty t.added_roots_queue) do - add_live t (Stable.to_linear_value (StableQueue.pop t.added_roots_queue)) + add_live t (StableQueue.pop t.added_roots_queue) done; (* 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 (Stable.to_linear_value src) + enqueue_expand t src done; while not (StableQueue.is_empty t.expansion_queue) do @@ -774,15 +743,15 @@ let apply_list t ~roots ~edges = m.expansion_edges_scanned + StableList.length succs; StableList.iter_with add_live t succs) done; - StableSet.iter_with - (fun t k -> emit_removal t (Stable.to_linear_value k) ()) - t t.deleted_nodes; + StableSet.iter_with (fun t k -> emit_removal t k ()) t t.deleted_nodes; let output_entries_list = if Invariants.enabled then ( let entries = ref [] in StableWave.iter t.output_wave (fun k v_opt -> entries := - (Stable.to_linear_value k, Stable.to_linear_value v_opt) :: !entries); + ( Stable.unsafe_to_nonlinear_value k, + Stable.unsafe_to_nonlinear_value v_opt ) + :: !entries); !entries) else [] in diff --git a/analysis/reactive/src/StableList.ml b/analysis/reactive/src/StableList.ml index 7c5212cba45..42dda4c6f78 100644 --- a/analysis/reactive/src/StableList.ml +++ b/analysis/reactive/src/StableList.ml @@ -20,10 +20,12 @@ let rec length_list acc = function let length xs = length_list 0 (list_of xs) +let[@inline] stable x = Stable.unsafe_of_value x + let rec iter_list f = function | [] -> () | x :: rest -> - f x; + f (stable x); iter_list f rest let iter f xs = iter_list f (list_of xs) @@ -31,19 +33,19 @@ let iter f xs = iter_list f (list_of xs) let rec iter_list_with f arg = function | [] -> () | x :: rest -> - f arg x; + f arg (stable x); iter_list_with f arg rest let iter_with f arg xs = iter_list_with f arg (list_of xs) let rec exists_list f = function | [] -> false - | x :: rest -> f x || exists_list f rest + | x :: rest -> f (stable x) || exists_list f rest let exists f xs = exists_list f (list_of xs) let rec exists_list_with f arg = function | [] -> false - | x :: rest -> f arg x || exists_list_with f arg rest + | x :: rest -> f arg (stable x) || exists_list_with f arg rest let exists_with f arg xs = exists_list_with f arg (list_of xs) diff --git a/analysis/reactive/src/StableList.mli b/analysis/reactive/src/StableList.mli index 43d17fda19f..d5d5288f443 100644 --- a/analysis/reactive/src/StableList.mli +++ b/analysis/reactive/src/StableList.mli @@ -22,7 +22,7 @@ val of_stable_list : 'a list Stable.t -> 'a t val empty : unit -> 'a t val is_empty : 'a t -> bool val length : 'a t -> int -val iter : ('a -> unit) -> 'a t -> unit -val iter_with : ('b -> 'a -> unit) -> 'b -> 'a t -> unit -val exists : ('a -> bool) -> 'a t -> bool -val exists_with : ('b -> 'a -> bool) -> 'b -> 'a t -> bool +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 From 71ace988f5e98cb7fc55e5731dc5ec3e3c7ae63c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 09:23:18 +0100 Subject: [PATCH 46/54] analysis/reactive: drop StableList.t wrapping, simplify to plain list type Rename StableList.inner to StableList.t (now just 'a list under the hood) and remove the old type 'a t = 'a inner Stable.t. The container storing a StableList is now responsible for the Stable.t wrapping. Add safe to_stable/maybe_to_stable conversions that hide unsafe_of_value, and restore of_list as a checked constructor. Add find_succs/succs_of_stable helpers in ReactiveFixpoint for the StableMap boundary. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/Reactive.ml | 8 +-- analysis/reactive/src/Reactive.mli | 2 +- analysis/reactive/src/ReactiveFixpoint.ml | 80 ++++++++++----------- analysis/reactive/src/ReactiveFixpoint.mli | 4 +- analysis/reactive/src/StableList.ml | 32 +++++---- analysis/reactive/src/StableList.mli | 22 +++--- analysis/reactive/test/AllocTest.ml | 4 +- analysis/reactive/test/TestHelpers.ml | 5 +- analysis/reanalyze/src/ReactiveLiveness.ml | 6 +- analysis/reanalyze/src/ReactiveLiveness.mli | 2 +- 10 files changed, 82 insertions(+), 83 deletions(-) diff --git a/analysis/reactive/src/Reactive.ml b/analysis/reactive/src/Reactive.ml index 13b4a8803f7..27f79d54ae4 100644 --- a/analysis/reactive/src/Reactive.ml +++ b/analysis/reactive/src/Reactive.ml @@ -800,8 +800,8 @@ module Fixpoint = struct let stable_wave_push wave k v = StableWave.push wave k v - let create ~name ~(init : ('k, unit) t) ~(edges : ('k, 'k StableList.inner) t) - () : ('k, unit) t = + 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 @@ -829,7 +829,7 @@ module Fixpoint = struct 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.inner Maybe.t) StableMap.t = + let edge_pending : ('k, 'k StableList.t Maybe.t) StableMap.t = StableMap.create () in let init_pending_count = ref 0 in @@ -903,7 +903,7 @@ module Fixpoint = struct let init_roots_wave = StableWave.create ~max_entries:(max 1 (init.length ())) () in - let init_edges_wave : ('k, 'k StableList.inner) StableWave.t = + let init_edges_wave : ('k, 'k StableList.t) StableWave.t = StableWave.create ~max_entries:(max 1 (edges.length ())) () in StableWave.clear init_roots_wave; diff --git a/analysis/reactive/src/Reactive.mli b/analysis/reactive/src/Reactive.mli index 2dcc5c8f5c8..b91c5ad1f9c 100644 --- a/analysis/reactive/src/Reactive.mli +++ b/analysis/reactive/src/Reactive.mli @@ -156,7 +156,7 @@ module Fixpoint : sig val create : name:string -> init:('k, unit) t -> - edges:('k, 'k StableList.inner) t -> + edges:('k, 'k StableList.t) t -> unit -> ('k, unit) t (** Compute transitive closure. diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 2b736c430b5..39ac524678d 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -17,7 +17,7 @@ type 'k metrics_state = { type 'k t = { current: 'k StableSet.t; - edge_map: ('k, 'k StableList.inner) StableMap.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; @@ -25,8 +25,8 @@ type 'k t = { deleted_nodes: 'k StableSet.t; rederive_pending: 'k StableSet.t; expansion_seen: 'k StableSet.t; - old_successors_for_changed: ('k, 'k StableList.inner) StableMap.t; - new_successors_for_changed: ('k, 'k StableList.inner) StableMap.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; @@ -57,6 +57,21 @@ let analyze_edge_change_has_new ~old_succs ~new_succs = let[@inline] stable_key k = Stable.unsafe_of_value k 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). *) @@ -83,7 +98,7 @@ let compute_reachable ~visited t = incr node_work; let r = StableMap.find_maybe t.edge_map k in if Maybe.is_some r then ( - let succs = Maybe.unsafe_get r in + let succs = succs_of_stable (Maybe.unsafe_get r) in edge_work := !edge_work + StableList.length succs; StableList.iter_with (bfs_visit_succ visited) frontier succs) done; @@ -263,16 +278,8 @@ module Invariants = struct (* Check each *) List.iter (fun src -> - let r_old = StableMap.find_maybe old_successors_for_changed src in - let old_succs = - if Maybe.is_some r_old then Maybe.unsafe_get r_old - else StableList.empty () - in - let r_new = StableMap.find_maybe new_successors_for_changed src in - let new_succs = - if Maybe.is_some r_new then Maybe.unsafe_get r_new - else StableList.empty () - in + let old_succs = find_succs old_successors_for_changed src in + let new_succs = find_succs new_successors_for_changed src in let expected_has_new = analyze_edge_change_has_new ~old_succs ~new_succs in @@ -449,10 +456,10 @@ let destroy t = let output_wave t = t.output_wave type 'k root_wave = ('k, unit Maybe.t) StableWave.t -type 'k edge_wave = ('k, 'k StableList.inner 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.inner) 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 @@ -478,15 +485,12 @@ 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 r = StableMap.find_maybe t.edge_map src in - let old_successors = - if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () - in + 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 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) @@ -508,7 +512,7 @@ let apply_edge_update t ~src ~new_successors = add_pred t ~target ~pred:src) () new_successors; - StableMap.replace t.edge_map src new_successors) + StableMap.replace t.edge_map src (StableList.to_stable new_successors)) let initialize t ~roots ~edges = StableSet.clear t.roots; @@ -516,17 +520,15 @@ let initialize t ~roots ~edges = 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:successors); + apply_edge_update t ~src:k ~new_successors:(succs_of_stable successors)); recompute_current t 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 Maybe.unsafe_get r - else - let r2 = StableMap.find_maybe t.edge_map k in - if Maybe.is_some r2 then Maybe.unsafe_get r2 else StableList.empty () + if Maybe.is_some r then succs_of_stable (Maybe.unsafe_get r) + else find_succs t.edge_map k let mark_deleted t k = if StableSet.mem t.current k && not (StableSet.mem t.deleted_nodes k) then ( @@ -573,15 +575,12 @@ let mark_deleted_unless_in_set 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 r = StableMap.find_maybe t.edge_map src in - let old_succs = - if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () - in - let new_succs = - if Maybe.is_some mv then Maybe.unsafe_get mv else StableList.empty () - in - StableMap.replace t.old_successors_for_changed src old_succs; - StableMap.replace t.new_successors_for_changed src new_succs; + 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 @@ -668,10 +667,7 @@ let apply_list t ~roots ~edges = (* 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 r = StableMap.find_maybe t.new_successors_for_changed src in - let new_succs = - if Maybe.is_some r then Maybe.unsafe_get r else StableList.empty () - 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 @@ -706,7 +702,7 @@ let apply_list t ~roots ~edges = 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 = Maybe.unsafe_get r in + 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; @@ -737,7 +733,7 @@ let apply_list t ~roots ~edges = 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 = Maybe.unsafe_get r in + 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; diff --git a/analysis/reactive/src/ReactiveFixpoint.mli b/analysis/reactive/src/ReactiveFixpoint.mli index 79a22752c09..ccb9a85c37f 100644 --- a/analysis/reactive/src/ReactiveFixpoint.mli +++ b/analysis/reactive/src/ReactiveFixpoint.mli @@ -4,10 +4,10 @@ type 'k t This implementation uses fixed-capacity arrays allocated in [create]. *) type 'k root_wave = ('k, unit Maybe.t) StableWave.t -type 'k edge_wave = ('k, 'k StableList.inner 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.inner) StableWave.t +type 'k edge_snapshot = ('k, 'k StableList.t) StableWave.t val create : max_nodes:int -> max_edges:int -> 'k t (** Create an empty state with fixed capacities. diff --git a/analysis/reactive/src/StableList.ml b/analysis/reactive/src/StableList.ml index 42dda4c6f78..5a8a3bc289d 100644 --- a/analysis/reactive/src/StableList.ml +++ b/analysis/reactive/src/StableList.ml @@ -1,16 +1,18 @@ -type 'a inner = 'a list -type 'a t = 'a inner Stable.t +type 'a t = 'a list -let unsafe_of_list = Stable.unsafe_of_value -let unsafe_inner_of_list (l : 'a list) : 'a inner = l -let of_list = Stable.of_value -let list_of = Stable.to_linear_value -let of_stable_list xs = xs +let unsafe_of_list (l : 'a list) : 'a t = l -let empty () : 'a t = Stable.of_value [] +let of_list (l : 'a list) : 'a t = + ignore (Stable.of_value l); + l -let is_empty xs = - match list_of xs with +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 = function | [] -> true | _ -> false @@ -18,7 +20,7 @@ let rec length_list acc = function | [] -> acc | _ :: rest -> length_list (acc + 1) rest -let length xs = length_list 0 (list_of xs) +let length xs = length_list 0 xs let[@inline] stable x = Stable.unsafe_of_value x @@ -28,7 +30,7 @@ let rec iter_list f = function f (stable x); iter_list f rest -let iter f xs = iter_list f (list_of xs) +let iter f xs = iter_list f xs let rec iter_list_with f arg = function | [] -> () @@ -36,16 +38,16 @@ let rec iter_list_with f arg = function f arg (stable x); iter_list_with f arg rest -let iter_with f arg xs = iter_list_with f arg (list_of xs) +let iter_with f arg xs = iter_list_with f arg xs let rec exists_list f = function | [] -> false | x :: rest -> f (stable x) || exists_list f rest -let exists f xs = exists_list f (list_of xs) +let exists f xs = exists_list f xs let rec exists_list_with f arg = function | [] -> false | x :: rest -> f arg (stable x) || exists_list_with f arg rest -let exists_with f arg xs = exists_list_with f arg (list_of xs) +let exists_with f arg xs = exists_list_with f arg xs diff --git a/analysis/reactive/src/StableList.mli b/analysis/reactive/src/StableList.mli index d5d5288f443..a7c07524442 100644 --- a/analysis/reactive/src/StableList.mli +++ b/analysis/reactive/src/StableList.mli @@ -1,23 +1,23 @@ -(** Stable-marked OCaml lists. +(** Lists intended for storage in stable (C-allocated) containers. - The list cells are ordinary OCaml heap values. This type makes the - boundary explicit when such a list is stored in a stable container. *) + The list cells are ordinary OCaml heap values. The container that + stores a [StableList.t] is responsible for the [Stable.t] wrapping. *) -type 'a inner -type 'a t = 'a inner Stable.t +type 'a t val unsafe_of_list : 'a list -> 'a t -(** Reinterpret a list as stable-marked without checking. *) - -val unsafe_inner_of_list : 'a list -> 'a inner -(** Reinterpret a list as a [StableList.inner] without checking. *) +(** 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 of_stable_list : 'a list Stable.t -> 'a t -(** Reinterpret an already stable-marked list as a stable-list value. *) +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 diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 4f476f1e3e6..15ee2f5b2f4 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -44,7 +44,7 @@ let test_fixpoint_alloc_n n = 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_inner_of_list edge_values.(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); @@ -382,7 +382,7 @@ let test_reactive_fixpoint_alloc_n n = StableWave.clear edge_wave; for i = 0 to n - 2 do StableWave.push edge_wave (stable_int i) - (Maybe.to_stable (Maybe.some edge_values_stable.(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 diff --git a/analysis/reactive/test/TestHelpers.ml b/analysis/reactive/test/TestHelpers.ml index e6ee896da6c..aa6263ee3c2 100644 --- a/analysis/reactive/test/TestHelpers.ml +++ b/analysis/reactive/test/TestHelpers.ml @@ -26,7 +26,7 @@ let emit_edge_set emit k vs = let w = wave () in StableWave.clear w; StableWave.push w (Stable.unsafe_of_value k) - (Maybe.to_stable (Maybe.some (StableList.unsafe_of_list vs))); + (StableList.maybe_to_stable (Maybe.some (StableList.unsafe_of_list vs))); emit w (** Emit a single remove entry *) @@ -70,7 +70,8 @@ let emit_edge_batch emit entries = match vs_opt with | Some vs -> StableWave.push w (Stable.unsafe_of_value k) - (Maybe.to_stable (Maybe.some (StableList.unsafe_of_list vs))) + (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 diff --git a/analysis/reanalyze/src/ReactiveLiveness.ml b/analysis/reanalyze/src/ReactiveLiveness.ml index 28fd4590afb..d61d6566e6a 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 StableList.inner) Reactive.t; + edges: (Lexing.position, Lexing.position StableList.t) Reactive.t; roots: (Lexing.position, unit) Reactive.t; } @@ -43,7 +43,7 @@ let create ~(merged : ReactiveMerge.t) : t = in (* Step 2: Convert to edges format for fixpoint: decl -> successor list *) - let edges : (Lexing.position, Lexing.position StableList.inner) Reactive.t = + 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 @@ -52,7 +52,7 @@ let create ~(merged : ReactiveMerge.t) : t = StableWave.push wave (Stable.unsafe_of_value pos) (Stable.unsafe_of_value - (StableList.unsafe_inner_of_list (PosSet.elements all_targets)))) + (StableList.unsafe_of_list (PosSet.elements all_targets)))) () in diff --git a/analysis/reanalyze/src/ReactiveLiveness.mli b/analysis/reanalyze/src/ReactiveLiveness.mli index 3602b196646..c603073248d 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 StableList.inner) Reactive.t; + edges: (Lexing.position, Lexing.position StableList.t) Reactive.t; roots: (Lexing.position, unit) Reactive.t; } From a2d95f74b20075f5b43aebd34032e03e57fd4e76 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 09:28:48 +0100 Subject: [PATCH 47/54] analysis/reactive: use 'a Stable.t list as StableList internal representation Elements are now pre-wrapped as Stable.t at creation time via a zero-cost %identity reinterpretation. This lets iter/exists/length delegate directly to List.iter/List.exists/List.length with no per-element conversion. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/StableList.ml | 55 +++++++++-------------------- 1 file changed, 17 insertions(+), 38 deletions(-) diff --git a/analysis/reactive/src/StableList.ml b/analysis/reactive/src/StableList.ml index 5a8a3bc289d..a7570d732de 100644 --- a/analysis/reactive/src/StableList.ml +++ b/analysis/reactive/src/StableList.ml @@ -1,53 +1,32 @@ -type 'a t = 'a list +type 'a t = 'a Stable.t list -let unsafe_of_list (l : 'a list) : 'a t = l +(* 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); - 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 is_empty = function - | [] -> true - | _ -> false - -let rec length_list acc = function - | [] -> acc - | _ :: rest -> length_list (acc + 1) rest - -let length xs = length_list 0 xs - -let[@inline] stable x = Stable.unsafe_of_value x - -let rec iter_list f = function +let rec iter_with f arg = function | [] -> () | x :: rest -> - f (stable x); - iter_list f rest + f arg x; + iter_with f arg rest -let iter f xs = iter_list f xs - -let rec iter_list_with f arg = function - | [] -> () - | x :: rest -> - f arg (stable x); - iter_list_with f arg rest - -let iter_with f arg xs = iter_list_with f arg xs - -let rec exists_list f = function +let rec exists_with f arg = function | [] -> false - | x :: rest -> f (stable x) || exists_list f rest - -let exists f xs = exists_list f xs - -let rec exists_list_with f arg = function - | [] -> false - | x :: rest -> f arg (stable x) || exists_list_with f arg rest - -let exists_with f arg xs = exists_list_with f arg xs + | x :: rest -> f arg x || exists_with f arg rest From c3ada974278040ca4647ed45f5dfe699234832bc Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 09:47:59 +0100 Subject: [PATCH 48/54] analysis/reactive: replace Hashtbl with StableSet in fixpoint invariants, skip alloc checks when invariants enabled Replace all Hashtbl usage in ReactiveFixpoint.Invariants with StableSet operations to avoid OCaml heap allocation. Add inv_pre_current, inv_scratch_a, inv_scratch_b scratch sets to the fixpoint state record. Remove stable_key helper and output_entries_list intermediate list. Skip allocation assertions in AllocTest when RESCRIPT_REACTIVE_FIXPOINT_ASSERT is enabled, since invariant checks themselves allocate. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 228 +++++++++------------- analysis/reactive/test/AllocTest.ml | 21 +- 2 files changed, 110 insertions(+), 139 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 39ac524678d..c4778cbaddf 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -37,24 +37,22 @@ type 'k t = { expansion_queue: 'k StableQueue.t; added_roots_queue: 'k StableQueue.t; edge_change_queue: 'k StableQueue.t; + (* Scratch sets for Invariants — allocated once, zero-alloc when used *) + inv_pre_current: 'k StableSet.t; + inv_scratch_a: 'k StableSet.t; + inv_scratch_b: 'k StableSet.t; metrics: 'k metrics_state; } -(* Standalone version for Invariants (no scratch sets available). - Debug-only — allocates temporary Hashtbl. *) -let analyze_edge_change_has_new ~old_succs ~new_succs = +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 - let old_set = Hashtbl.create (StableList.length old_succs) in - StableList.iter - (fun k -> Hashtbl.replace old_set (Stable.unsafe_to_nonlinear_value k) ()) - old_succs; - StableList.exists - (fun tgt -> not (Hashtbl.mem old_set (Stable.to_linear_value tgt))) - new_succs - -let[@inline] stable_key k = Stable.unsafe_of_value k + else begin + StableSet.clear scratch; + StableList.iter (fun k -> StableSet.add scratch k) old_succs; + StableList.exists (fun tgt -> not (StableSet.mem scratch tgt)) new_succs + end + let[@inline] enqueue q k = StableQueue.push q k (* Helpers for StableList values stored in StableMap/StableWave. @@ -243,51 +241,35 @@ module Invariants = struct let assert_ condition message = if enabled && not condition then failwith message - (* Debug-only: copies a set into a Hashtbl for diffing. - These allocations are acceptable since Invariants is opt-in debug code. *) - let copy_set_to_hashtbl (s : 'k StableSet.t) = - let out = Hashtbl.create (StableSet.cardinal s) in - StableSet.iter_with - (fun out k -> Hashtbl.replace out (Stable.unsafe_to_nonlinear_value k) ()) - out s; - out - - let set_equal a b = - Hashtbl.length a = Hashtbl.length b + let stable_set_equal a b = + StableSet.cardinal a = StableSet.cardinal b && let ok = ref true in - Hashtbl.iter (fun k () -> if not (Hashtbl.mem b k) then ok := false) a; + StableSet.iter_with + (fun (ok, b) k -> if !ok && not (StableSet.mem b k) then ok := false) + (ok, b) a; !ok - let assert_edge_has_new_consistent ~edge_change_queue - ~old_successors_for_changed ~new_successors_for_changed ~edge_has_new = - if enabled then ( - let q_copy = StableQueue.create () in - (* Drain and re-push to iterate without consuming *) - let items = ref [] in - while not (StableQueue.is_empty edge_change_queue) do - let src = StableQueue.pop edge_change_queue in - items := src :: !items; - StableQueue.push q_copy src - done; - (* Restore queue *) - List.iter - (fun src -> StableQueue.push edge_change_queue src) - (List.rev !items); - StableQueue.destroy q_copy; - (* Check each *) - List.iter - (fun src -> - let old_succs = find_succs old_successors_for_changed src in - let new_succs = find_succs new_successors_for_changed src in + let copy_stable_set ~dst src = + StableSet.clear dst; + StableSet.iter_with (fun dst k -> StableSet.add dst k) dst src + + let assert_edge_has_new_consistent ~inv_scratch_a ~old_successors_for_changed + ~new_successors_for_changed ~edge_has_new = + if enabled then + StableMap.iter_with + (fun (scratch, new_map, edge_has_new) src old_succs_s -> + let old_succs = succs_of_stable old_succs_s in + let new_succs = find_succs new_map src in let expected_has_new = - analyze_edge_change_has_new ~old_succs ~new_succs + analyze_edge_change_has_new scratch ~old_succs ~new_succs in let actual_has_new = StableSet.mem edge_has_new src in assert_ (expected_has_new = actual_has_new) "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") - !items) + (inv_scratch_a, new_successors_for_changed, edge_has_new) + old_successors_for_changed let assert_deleted_nodes_closed ~current ~deleted_nodes ~(old_successors : 'k Stable.t -> 'k StableList.t) = @@ -318,82 +300,76 @@ module Invariants = struct left behind") () deleted_nodes - let assert_current_minus_deleted ~pre_current ~current ~deleted_nodes = + let assert_current_minus_deleted ~inv_scratch_a ~pre_current ~current + ~deleted_nodes = if enabled then ( - let expected = Hashtbl.copy pre_current in + copy_stable_set ~dst:inv_scratch_a pre_current; StableSet.iter_with - (fun expected k -> Hashtbl.remove expected (Stable.to_linear_value k)) - expected deleted_nodes; - let current_ht = copy_set_to_hashtbl current in + (fun dst k -> StableSet.remove dst k) + inv_scratch_a deleted_nodes; assert_ - (set_equal expected current_ht) + (stable_set_equal inv_scratch_a current) "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ deleted") - let assert_removal_output_matches ~output_entries ~deleted_nodes ~current = + let assert_removal_output_matches ~inv_scratch_a ~inv_scratch_b ~output_wave + ~deleted_nodes ~current = if enabled then ( - let expected = Hashtbl.create (StableSet.cardinal deleted_nodes) in + StableSet.clear inv_scratch_a; StableSet.iter_with - (fun expected k -> - if not (StableSet.mem current k) then - Hashtbl.replace expected (Stable.unsafe_to_nonlinear_value k) ()) - expected deleted_nodes; - let actual = Hashtbl.create (List.length output_entries) in - List.iter - (fun (k, mv) -> - if not (Maybe.is_some mv) then Hashtbl.replace actual k ()) - output_entries; + (fun (dst, current) k -> + if not (StableSet.mem current k) then StableSet.add dst k) + (inv_scratch_a, current) deleted_nodes; + StableSet.clear inv_scratch_b; + StableWave.iter_with output_wave + (fun dst k mv -> + if not (Maybe.is_some (Stable.to_linear_value mv)) then + StableSet.add dst k) + inv_scratch_b; assert_ - (set_equal expected actual) + (stable_set_equal inv_scratch_a inv_scratch_b) "ReactiveFixpoint.apply invariant failed: removal output mismatch") - let assert_final_fixpoint_and_delta ~visited ~t ~pre_current ~output_entries = + let assert_final_fixpoint_and_delta ~inv_scratch_a ~inv_scratch_b ~visited ~t + ~pre_current ~output_wave = if enabled then ( ignore (compute_reachable ~visited t); - let reachable = copy_set_to_hashtbl visited in - let current_ht = copy_set_to_hashtbl t.current in assert_ - (set_equal reachable current_ht) + (stable_set_equal visited t.current) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; - - let expected_adds = Hashtbl.create (StableSet.cardinal t.current) in - let expected_removes = Hashtbl.create (Hashtbl.length pre_current) in + (* Check adds *) + StableSet.clear inv_scratch_a; + StableSet.iter_with + (fun (dst, pre) k -> if not (StableSet.mem pre k) then StableSet.add dst k) + (inv_scratch_a, pre_current) t.current; + StableSet.clear inv_scratch_b; + StableWave.iter_with output_wave + (fun dst k mv -> + if Maybe.is_some (Stable.to_linear_value mv) then StableSet.add dst k) + inv_scratch_b; + let adds_ok = stable_set_equal inv_scratch_a inv_scratch_b in + (* Check removes *) + StableSet.clear inv_scratch_a; StableSet.iter_with - (fun expected_adds k -> - let k_raw = Stable.unsafe_to_nonlinear_value k in - if not (Hashtbl.mem pre_current k_raw) then - Hashtbl.replace expected_adds k_raw ()) - expected_adds t.current; - Hashtbl.iter - (fun k () -> - if not (StableSet.mem t.current (stable_key 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, mv) -> - if Maybe.is_some mv then Hashtbl.replace actual_adds k () - else 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 + (fun (dst, current) k -> + if not (StableSet.mem current k) then StableSet.add dst k) + (inv_scratch_a, t.current) pre_current; + StableSet.clear inv_scratch_b; + StableWave.iter_with output_wave + (fun dst k mv -> + if not (Maybe.is_some (Stable.to_linear_value mv)) then + StableSet.add dst k) + inv_scratch_b; + let removes_ok = stable_set_equal inv_scratch_a inv_scratch_b 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) + (pre=%d final=%d output=%d)" + (StableSet.cardinal pre_current) (StableSet.cardinal t.current) - (List.length output_entries) - (Hashtbl.length expected_adds) - (Hashtbl.length actual_adds) - (Hashtbl.length expected_removes) - (Hashtbl.length actual_removes))) + (StableWave.count output_wave))) end let create ~max_nodes ~max_edges = @@ -419,6 +395,9 @@ let create ~max_nodes ~max_edges = expansion_queue = StableQueue.create (); added_roots_queue = StableQueue.create (); edge_change_queue = StableQueue.create (); + inv_pre_current = StableSet.create (); + inv_scratch_a = StableSet.create (); + inv_scratch_b = StableSet.create (); new_successors_for_changed = StableMap.create (); metrics = { @@ -451,6 +430,9 @@ let destroy t = StableQueue.destroy t.expansion_queue; StableQueue.destroy t.added_roots_queue; StableQueue.destroy t.edge_change_queue; + StableSet.destroy t.inv_pre_current; + StableSet.destroy t.inv_scratch_a; + StableSet.destroy t.inv_scratch_b; StableSet.destroy t.metrics.scratch_reachable; StableWave.destroy t.output_wave let output_wave t = t.output_wave @@ -613,10 +595,8 @@ 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 = - let pre_current = - if Invariants.enabled then Some (Invariants.copy_set_to_hashtbl t.current) - else None - in + if Invariants.enabled then + Invariants.copy_stable_set ~dst:t.inv_pre_current t.current; (* Clear all scratch state up front *) StableSet.clear t.deleted_nodes; StableQueue.clear t.delete_queue; @@ -640,8 +620,7 @@ let apply_list t ~roots ~edges = (fun t src mv -> scan_edge_entry t src (Maybe.of_stable mv)) t; - Invariants.assert_edge_has_new_consistent - ~edge_change_queue:t.edge_change_queue + Invariants.assert_edge_has_new_consistent ~inv_scratch_a:t.inv_scratch_a ~old_successors_for_changed:t.old_successors_for_changed ~new_successors_for_changed:t.new_successors_for_changed ~edge_has_new:t.edge_has_new; @@ -675,11 +654,10 @@ let apply_list t ~roots ~edges = StableMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; StableSet.iter_with remove_from_current t t.deleted_nodes; - (match pre_current with - | Some pre -> - Invariants.assert_current_minus_deleted ~pre_current:pre ~current:t.current - ~deleted_nodes:t.deleted_nodes - | None -> ()); + if Invariants.enabled then + Invariants.assert_current_minus_deleted ~inv_scratch_a:t.inv_scratch_a + ~pre_current:t.inv_pre_current ~current:t.current + ~deleted_nodes:t.deleted_nodes; (* Phase 4: rederive *) StableQueue.clear t.rederive_queue; @@ -740,25 +718,13 @@ let apply_list t ~roots ~edges = StableList.iter_with add_live t succs) done; StableSet.iter_with (fun t k -> emit_removal t k ()) t t.deleted_nodes; - let output_entries_list = - if Invariants.enabled then ( - let entries = ref [] in - StableWave.iter t.output_wave (fun k v_opt -> - entries := - ( Stable.unsafe_to_nonlinear_value k, - Stable.unsafe_to_nonlinear_value v_opt ) - :: !entries); - !entries) - else [] - in - Invariants.assert_removal_output_matches ~output_entries:output_entries_list + Invariants.assert_removal_output_matches ~inv_scratch_a:t.inv_scratch_a + ~inv_scratch_b:t.inv_scratch_b ~output_wave:t.output_wave ~deleted_nodes:t.deleted_nodes ~current:t.current; - (match pre_current with - | Some pre -> - Invariants.assert_final_fixpoint_and_delta - ~visited:t.metrics.scratch_reachable ~t ~pre_current:pre - ~output_entries:output_entries_list - | None -> ()); + if Invariants.enabled then + Invariants.assert_final_fixpoint_and_delta ~inv_scratch_a:t.inv_scratch_a + ~inv_scratch_b:t.inv_scratch_b ~visited:t.metrics.scratch_reachable ~t + ~pre_current:t.inv_pre_current ~output_wave:t.output_wave; if Metrics.enabled then let full_node_work, full_edge_work = diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 15ee2f5b2f4..6af2926b608 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -5,6 +5,11 @@ open TestHelpers +let check_alloc = + match Sys.getenv_opt "RESCRIPT_REACTIVE_FIXPOINT_ASSERT" with + | Some ("1" | "true" | "TRUE" | "yes" | "YES") -> false + | _ -> true + let words_since = AllocMeasure.words_since let stable_int = Stable.int @@ -84,7 +89,7 @@ let test_fixpoint_alloc () = (fun n -> let words = test_fixpoint_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -147,7 +152,7 @@ let test_flatmap_alloc () = (fun n -> let words = test_flatmap_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -206,7 +211,7 @@ let test_union_alloc () = (fun n -> let words = test_union_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -287,7 +292,7 @@ let test_join_alloc () = (fun n -> let words = test_join_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -361,7 +366,7 @@ let test_reactive_join_alloc () = (fun n -> let words = test_reactive_join_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -427,7 +432,7 @@ let test_reactive_fixpoint_alloc () = (fun n -> let words = test_reactive_fixpoint_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -488,7 +493,7 @@ let test_reactive_union_alloc () = (fun n -> let words = test_reactive_union_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); @@ -551,7 +556,7 @@ let test_reactive_flatmap_alloc () = (fun n -> let words = test_reactive_flatmap_alloc_n n in Printf.printf " n=%d: %d words/iter\n" n words; - assert (words = 0)) + if check_alloc then assert (words = 0)) [10; 100; 1000]; print_stable_usage (); assert (Allocator.live_block_count () = 0); From c98f30161598521cc7a2ad2e2a2fd97124fd5bca Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 10:04:30 +0100 Subject: [PATCH 49/54] analysis/reactive: zero-alloc fixpoint invariants Eliminate all OCaml heap allocation in invariant checks so tests pass with RESCRIPT_REACTIVE_FIXPOINT_ASSERT=1 and zero words/iter. - Move is_supported, old_successors, has_live_predecessor before Invariants module so callbacks can reference them directly - Add fill_reachable_scratch: BFS taking t directly (no ref/tuple) - Use exception for stable_set_equal (no ref/tuple) - All invariant functions take t directly (no tuple args at call sites) - Extract all callbacks as top-level functions (no per-call closures) - Change alloc skip flag to RESCRIPT_REACTIVE_SKIP_ALLOC_ASSERT Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 289 +++++++++++----------- analysis/reactive/test/AllocTest.ml | 2 +- 2 files changed, 145 insertions(+), 146 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index c4778cbaddf..2e82d173307 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -44,14 +44,16 @@ type 'k t = { metrics: 'k metrics_state; } +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 begin + else ( StableSet.clear scratch; - StableList.iter (fun k -> StableSet.add scratch k) old_succs; - StableList.exists (fun tgt -> not (StableSet.mem scratch tgt)) new_succs - end + 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 @@ -73,11 +75,11 @@ let[@inline] succs_of_maybe mv = (* 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_root visited frontier _t k () = +let bfs_seed (visited, frontier) k = StableSet.add visited k; StableQueue.push frontier k -let bfs_visit_succ visited frontier succ = +let bfs_visit_succ (visited, frontier) succ = if not (StableSet.mem visited succ) then ( StableSet.add visited succ; StableQueue.push frontier succ) @@ -88,9 +90,8 @@ let compute_reachable ~visited t = StableQueue.clear frontier; let node_work = ref 0 in let edge_work = ref 0 in - StableSet.iter_with - (fun (visited, frontier) k -> bfs_seed_root visited frontier t k ()) - (visited, frontier) t.roots; + 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; @@ -98,10 +99,45 @@ let compute_reachable ~visited t = 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 visited) frontier succs) + StableList.iter_with bfs_visit_succ vf succs) done; (!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 = match Sys.getenv_opt "RESCRIPT_REACTIVE_FIXPOINT_METRICS" with @@ -226,6 +262,8 @@ module Metrics = struct let () = at_exit emit_summary end +exception Sets_not_equal + module Invariants = struct let enabled = match Sys.getenv_opt "RESCRIPT_REACTIVE_FIXPOINT_ASSERT" with @@ -241,135 +279,127 @@ module Invariants = struct let assert_ condition message = if enabled && not condition then failwith message + let check_mem_b b k = if not (StableSet.mem b k) then raise Sets_not_equal + let stable_set_equal a b = StableSet.cardinal a = StableSet.cardinal b && - let ok = ref true in - StableSet.iter_with - (fun (ok, b) k -> if !ok && not (StableSet.mem b k) then ok := false) - (ok, b) a; - !ok + match StableSet.iter_with check_mem_b b a with + | () -> true + | exception Sets_not_equal -> false let copy_stable_set ~dst src = StableSet.clear dst; - StableSet.iter_with (fun dst k -> StableSet.add dst k) dst src + StableSet.iter_with set_add_k dst src + + (* Callbacks for assert_edge_has_new_consistent — take t directly *) + let check_edge_has_new_entry 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 expected_has_new = + analyze_edge_change_has_new t.inv_scratch_a ~old_succs ~new_succs + in + let actual_has_new = StableSet.mem t.edge_has_new src in + assert_ + (expected_has_new = actual_has_new) + "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new" - let assert_edge_has_new_consistent ~inv_scratch_a ~old_successors_for_changed - ~new_successors_for_changed ~edge_has_new = + let assert_edge_has_new_consistent t = if enabled then - StableMap.iter_with - (fun (scratch, new_map, edge_has_new) src old_succs_s -> - let old_succs = succs_of_stable old_succs_s in - let new_succs = find_succs new_map src in - let expected_has_new = - analyze_edge_change_has_new scratch ~old_succs ~new_succs - in - let actual_has_new = StableSet.mem edge_has_new src in - assert_ - (expected_has_new = actual_has_new) - "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new") - (inv_scratch_a, new_successors_for_changed, edge_has_new) - old_successors_for_changed - - let assert_deleted_nodes_closed ~current ~deleted_nodes - ~(old_successors : 'k Stable.t -> 'k StableList.t) = + StableMap.iter_with check_edge_has_new_entry t + t.old_successors_for_changed + + (* Callbacks for assert_deleted_nodes_closed — take t directly *) + 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 - StableSet.iter_with - (fun () k -> - assert_ (StableSet.mem current k) - "ReactiveFixpoint.apply invariant failed: deleted node not in \ - current"; - StableList.iter - (fun succ -> - if StableSet.mem current succ then - assert_ - (StableSet.mem deleted_nodes succ) - "ReactiveFixpoint.apply invariant failed: deleted closure \ - broken") - (old_successors k)) - () deleted_nodes - - let assert_no_supported_deleted_left ~deleted_nodes ~current ~supported = + 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 - StableSet.iter_with - (fun () k -> - if not (StableSet.mem current k) then - assert_ - (not (supported k)) - "ReactiveFixpoint.apply invariant failed: supported deleted node \ - left behind") - () deleted_nodes - - let assert_current_minus_deleted ~inv_scratch_a ~pre_current ~current - ~deleted_nodes = + StableSet.iter_with check_no_supported_deleted t t.deleted_nodes + + let assert_current_minus_deleted t = if enabled then ( - copy_stable_set ~dst:inv_scratch_a pre_current; + copy_stable_set ~dst:t.inv_scratch_a t.inv_pre_current; StableSet.iter_with (fun dst k -> StableSet.remove dst k) - inv_scratch_a deleted_nodes; + t.inv_scratch_a t.deleted_nodes; assert_ - (stable_set_equal inv_scratch_a current) + (stable_set_equal t.inv_scratch_a t.current) "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ deleted") - let assert_removal_output_matches ~inv_scratch_a ~inv_scratch_b ~output_wave - ~deleted_nodes ~current = + (* Callbacks for assert_removal_output_matches / assert_final_fixpoint *) + let add_to_a_if_not_in_current t k = + if not (StableSet.mem t.current k) then StableSet.add t.inv_scratch_a k + + let add_to_b_if_none dst k mv = + if not (Maybe.is_some (Stable.to_linear_value mv)) then StableSet.add dst k + + let add_to_a_if_not_in_pre t k = + if not (StableSet.mem t.inv_pre_current k) then + StableSet.add t.inv_scratch_a k + + let add_to_b_if_some dst k mv = + if Maybe.is_some (Stable.to_linear_value mv) then StableSet.add dst k + + let assert_removal_output_matches t = if enabled then ( - StableSet.clear inv_scratch_a; - StableSet.iter_with - (fun (dst, current) k -> - if not (StableSet.mem current k) then StableSet.add dst k) - (inv_scratch_a, current) deleted_nodes; - StableSet.clear inv_scratch_b; - StableWave.iter_with output_wave - (fun dst k mv -> - if not (Maybe.is_some (Stable.to_linear_value mv)) then - StableSet.add dst k) - inv_scratch_b; + StableSet.clear t.inv_scratch_a; + StableSet.iter_with add_to_a_if_not_in_current t t.deleted_nodes; + StableSet.clear t.inv_scratch_b; + StableWave.iter_with t.output_wave add_to_b_if_none t.inv_scratch_b; assert_ - (stable_set_equal inv_scratch_a inv_scratch_b) + (stable_set_equal t.inv_scratch_a t.inv_scratch_b) "ReactiveFixpoint.apply invariant failed: removal output mismatch") - let assert_final_fixpoint_and_delta ~inv_scratch_a ~inv_scratch_b ~visited ~t - ~pre_current ~output_wave = + let assert_final_fixpoint_and_delta t = if enabled then ( - ignore (compute_reachable ~visited t); + fill_reachable_scratch t; assert_ - (stable_set_equal visited t.current) + (stable_set_equal t.metrics.scratch_reachable t.current) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; - (* Check adds *) - StableSet.clear inv_scratch_a; - StableSet.iter_with - (fun (dst, pre) k -> if not (StableSet.mem pre k) then StableSet.add dst k) - (inv_scratch_a, pre_current) t.current; - StableSet.clear inv_scratch_b; - StableWave.iter_with output_wave - (fun dst k mv -> - if Maybe.is_some (Stable.to_linear_value mv) then StableSet.add dst k) - inv_scratch_b; - let adds_ok = stable_set_equal inv_scratch_a inv_scratch_b in - (* Check removes *) - StableSet.clear inv_scratch_a; - StableSet.iter_with - (fun (dst, current) k -> - if not (StableSet.mem current k) then StableSet.add dst k) - (inv_scratch_a, t.current) pre_current; - StableSet.clear inv_scratch_b; - StableWave.iter_with output_wave - (fun dst k mv -> - if not (Maybe.is_some (Stable.to_linear_value mv)) then - StableSet.add dst k) - inv_scratch_b; - let removes_ok = stable_set_equal inv_scratch_a inv_scratch_b in + (* Check adds: nodes in current but not in pre_current *) + StableSet.clear t.inv_scratch_a; + StableSet.iter_with add_to_a_if_not_in_pre t t.current; + StableSet.clear t.inv_scratch_b; + StableWave.iter_with t.output_wave add_to_b_if_some t.inv_scratch_b; + let adds_ok = stable_set_equal t.inv_scratch_a t.inv_scratch_b in + (* Check removes: nodes in pre_current but not in current *) + StableSet.clear t.inv_scratch_a; + StableSet.iter_with add_to_a_if_not_in_current t t.inv_pre_current; + StableSet.clear t.inv_scratch_b; + StableWave.iter_with t.output_wave add_to_b_if_none t.inv_scratch_b; + let removes_ok = stable_set_equal t.inv_scratch_a t.inv_scratch_b in if not (adds_ok && removes_ok) then failwith (Printf.sprintf "ReactiveFixpoint.apply invariant failed: output delta mismatch \ (pre=%d final=%d output=%d)" - (StableSet.cardinal pre_current) + (StableSet.cardinal t.inv_pre_current) (StableSet.cardinal t.current) - (StableWave.count output_wave))) + (StableWave.count t.output_wave))) end let create ~max_nodes ~max_edges = @@ -458,11 +488,6 @@ let add_pred t ~target ~pred = StableMapSet.add t.pred_map target pred let remove_pred t ~target ~pred = StableMapSet.remove_from_set_and_recycle_if_empty t.pred_map target pred -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 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 @@ -505,13 +530,6 @@ let initialize t ~roots ~edges = apply_edge_update t ~src:k ~new_successors:(succs_of_stable successors)); recompute_current t -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 - 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; @@ -544,13 +562,9 @@ let scan_root_entry t k mv = 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 set_add_k set k = StableSet.add set k - let mark_deleted_if_absent (t, set) k = if not (StableSet.mem set k) then mark_deleted t k -let not_in_set set k = not (StableSet.mem set k) - let mark_deleted_unless_in_set t set xs = StableList.iter_with mark_deleted_if_absent (t, set) xs @@ -620,10 +634,7 @@ let apply_list t ~roots ~edges = (fun t src mv -> scan_edge_entry t src (Maybe.of_stable mv)) t; - Invariants.assert_edge_has_new_consistent ~inv_scratch_a:t.inv_scratch_a - ~old_successors_for_changed:t.old_successors_for_changed - ~new_successors_for_changed:t.new_successors_for_changed - ~edge_has_new:t.edge_has_new; + Invariants.assert_edge_has_new_consistent t; (* Phase 2: delete BFS *) while not (StableQueue.is_empty t.delete_queue) do @@ -634,9 +645,7 @@ let apply_list t ~roots ~edges = m.delete_edges_scanned <- m.delete_edges_scanned + StableList.length succs); StableList.iter_with mark_deleted t succs done; - if Invariants.enabled then - Invariants.assert_deleted_nodes_closed ~current:t.current - ~deleted_nodes:t.deleted_nodes ~old_successors:(old_successors t); + Invariants.assert_deleted_nodes_closed t; (* Phase 3: apply root and edge mutations *) StableWave.iter_with roots @@ -654,10 +663,7 @@ let apply_list t ~roots ~edges = StableMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; StableSet.iter_with remove_from_current t t.deleted_nodes; - if Invariants.enabled then - Invariants.assert_current_minus_deleted ~inv_scratch_a:t.inv_scratch_a - ~pre_current:t.inv_pre_current ~current:t.current - ~deleted_nodes:t.deleted_nodes; + Invariants.assert_current_minus_deleted t; (* Phase 4: rederive *) StableQueue.clear t.rederive_queue; @@ -686,9 +692,7 @@ let apply_list t ~roots ~edges = m.rederive_edges_scanned + StableList.length succs; StableList.iter_with enqueue_rederive_if_needed t succs)) done; - if Invariants.enabled then - Invariants.assert_no_supported_deleted_left ~deleted_nodes:t.deleted_nodes - ~current:t.current ~supported:(is_supported t); + Invariants.assert_no_supported_deleted_left t; (* Phase 5: expansion *) StableQueue.clear t.expansion_queue; @@ -718,13 +722,8 @@ let apply_list t ~roots ~edges = 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 ~inv_scratch_a:t.inv_scratch_a - ~inv_scratch_b:t.inv_scratch_b ~output_wave:t.output_wave - ~deleted_nodes:t.deleted_nodes ~current:t.current; - if Invariants.enabled then - Invariants.assert_final_fixpoint_and_delta ~inv_scratch_a:t.inv_scratch_a - ~inv_scratch_b:t.inv_scratch_b ~visited:t.metrics.scratch_reachable ~t - ~pre_current:t.inv_pre_current ~output_wave:t.output_wave; + Invariants.assert_removal_output_matches t; + Invariants.assert_final_fixpoint_and_delta t; if Metrics.enabled then let full_node_work, full_edge_work = diff --git a/analysis/reactive/test/AllocTest.ml b/analysis/reactive/test/AllocTest.ml index 6af2926b608..6b19aacb171 100644 --- a/analysis/reactive/test/AllocTest.ml +++ b/analysis/reactive/test/AllocTest.ml @@ -6,7 +6,7 @@ open TestHelpers let check_alloc = - match Sys.getenv_opt "RESCRIPT_REACTIVE_FIXPOINT_ASSERT" with + match Sys.getenv_opt "RESCRIPT_REACTIVE_SKIP_ALLOC_ASSERT" with | Some ("1" | "true" | "TRUE" | "yes" | "YES") -> false | _ -> true From 3b2442484b9b9ee248b1e4d12d159e6efb9a6258 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 10:07:52 +0100 Subject: [PATCH 50/54] analysis/reactive: add StableSet.equal and StableSet.copy, remove Sets_not_equal exception Move stable_set_equal and copy_stable_set from ReactiveFixpoint.Invariants into StableSet as proper operations that can benefit from internal implementation details (direct slot iteration, no closures/exceptions). Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 30 ++++++----------------- analysis/reactive/src/StableSet.ml | 22 +++++++++++++++++ analysis/reactive/src/StableSet.mli | 6 +++++ 3 files changed, 35 insertions(+), 23 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 2e82d173307..9c5342750a3 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -262,8 +262,6 @@ module Metrics = struct let () = at_exit emit_summary end -exception Sets_not_equal - module Invariants = struct let enabled = match Sys.getenv_opt "RESCRIPT_REACTIVE_FIXPOINT_ASSERT" with @@ -279,19 +277,6 @@ module Invariants = struct let assert_ condition message = if enabled && not condition then failwith message - let check_mem_b b k = if not (StableSet.mem b k) then raise Sets_not_equal - - let stable_set_equal a b = - StableSet.cardinal a = StableSet.cardinal b - && - match StableSet.iter_with check_mem_b b a with - | () -> true - | exception Sets_not_equal -> false - - let copy_stable_set ~dst src = - StableSet.clear dst; - StableSet.iter_with set_add_k dst src - (* Callbacks for assert_edge_has_new_consistent — take t directly *) let check_edge_has_new_entry t src old_succs_s = let old_succs = succs_of_stable old_succs_s in @@ -340,12 +325,12 @@ module Invariants = struct let assert_current_minus_deleted t = if enabled then ( - copy_stable_set ~dst:t.inv_scratch_a t.inv_pre_current; + StableSet.copy ~dst:t.inv_scratch_a t.inv_pre_current; StableSet.iter_with (fun dst k -> StableSet.remove dst k) t.inv_scratch_a t.deleted_nodes; assert_ - (stable_set_equal t.inv_scratch_a t.current) + (StableSet.equal t.inv_scratch_a t.current) "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ deleted") @@ -370,14 +355,14 @@ module Invariants = struct StableSet.clear t.inv_scratch_b; StableWave.iter_with t.output_wave add_to_b_if_none t.inv_scratch_b; assert_ - (stable_set_equal t.inv_scratch_a t.inv_scratch_b) + (StableSet.equal t.inv_scratch_a t.inv_scratch_b) "ReactiveFixpoint.apply invariant failed: removal output mismatch") let assert_final_fixpoint_and_delta t = if enabled then ( fill_reachable_scratch t; assert_ - (stable_set_equal t.metrics.scratch_reachable t.current) + (StableSet.equal t.metrics.scratch_reachable t.current) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; (* Check adds: nodes in current but not in pre_current *) @@ -385,13 +370,13 @@ module Invariants = struct StableSet.iter_with add_to_a_if_not_in_pre t t.current; StableSet.clear t.inv_scratch_b; StableWave.iter_with t.output_wave add_to_b_if_some t.inv_scratch_b; - let adds_ok = stable_set_equal t.inv_scratch_a t.inv_scratch_b in + let adds_ok = StableSet.equal t.inv_scratch_a t.inv_scratch_b in (* Check removes: nodes in pre_current but not in current *) StableSet.clear t.inv_scratch_a; StableSet.iter_with add_to_a_if_not_in_current t t.inv_pre_current; StableSet.clear t.inv_scratch_b; StableWave.iter_with t.output_wave add_to_b_if_none t.inv_scratch_b; - let removes_ok = stable_set_equal t.inv_scratch_a t.inv_scratch_b in + let removes_ok = StableSet.equal t.inv_scratch_a t.inv_scratch_b in if not (adds_ok && removes_ok) then failwith (Printf.sprintf @@ -609,8 +594,7 @@ 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 = - if Invariants.enabled then - Invariants.copy_stable_set ~dst:t.inv_pre_current t.current; + if Invariants.enabled then StableSet.copy ~dst:t.inv_pre_current t.current; (* Clear all scratch state up front *) StableSet.clear t.deleted_nodes; StableQueue.clear t.delete_queue; diff --git a/analysis/reactive/src/StableSet.ml b/analysis/reactive/src/StableSet.ml index 2c1cc76688b..f5ac1d5bff8 100644 --- a/analysis/reactive/src/StableSet.ml +++ b/analysis/reactive/src/StableSet.ml @@ -151,4 +151,26 @@ let exists_with (type a k) (f : a -> k Stable.t -> bool) (arg : a) (t : k t) = 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 index 08185a13aa3..08049bcf327 100644 --- a/analysis/reactive/src/StableSet.mli +++ b/analysis/reactive/src/StableSet.mli @@ -30,5 +30,11 @@ val iter_with : ('b -> 'a Stable.t -> unit) -> 'b -> 'a t -> unit 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. *) From a19675e25ecafe8ff3e4081524b2232ebba0e69a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 10:43:31 +0100 Subject: [PATCH 51/54] analysis/reactive: move invariant scratch sets out of t, add iter_with2 Move inv_pre_current, inv_scratch_a, inv_scratch_b out of the fixpoint record type. They are now created/destroyed locally in apply_list using Maybe.t for safe optional access. Add iter_with2 to StableSet and StableMap to pass two args without partial-application closures, maintaining zero OCaml heap allocation even with invariants enabled. Co-Authored-By: Claude Opus 4.6 --- analysis/reactive/src/ReactiveFixpoint.ml | 133 ++++++++++++---------- analysis/reactive/src/StableMap.ml | 9 ++ analysis/reactive/src/StableMap.mli | 7 ++ analysis/reactive/src/StableSet.ml | 8 ++ analysis/reactive/src/StableSet.mli | 3 + 5 files changed, 99 insertions(+), 61 deletions(-) diff --git a/analysis/reactive/src/ReactiveFixpoint.ml b/analysis/reactive/src/ReactiveFixpoint.ml index 9c5342750a3..13224dd54d0 100644 --- a/analysis/reactive/src/ReactiveFixpoint.ml +++ b/analysis/reactive/src/ReactiveFixpoint.ml @@ -37,10 +37,6 @@ type 'k t = { expansion_queue: 'k StableQueue.t; added_roots_queue: 'k StableQueue.t; edge_change_queue: 'k StableQueue.t; - (* Scratch sets for Invariants — allocated once, zero-alloc when used *) - inv_pre_current: 'k StableSet.t; - inv_scratch_a: 'k StableSet.t; - inv_scratch_b: 'k StableSet.t; metrics: 'k metrics_state; } @@ -277,24 +273,24 @@ module Invariants = struct let assert_ condition message = if enabled && not condition then failwith message - (* Callbacks for assert_edge_has_new_consistent — take t directly *) - let check_edge_has_new_entry t src old_succs_s = + (* 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 expected_has_new = - analyze_edge_change_has_new t.inv_scratch_a ~old_succs ~new_succs + let recomputed = + analyze_edge_change_has_new old_succs_set ~old_succs ~new_succs in - let actual_has_new = StableSet.mem t.edge_has_new src in assert_ - (expected_has_new = actual_has_new) + (recomputed = StableSet.mem t.edge_has_new src) "ReactiveFixpoint.apply invariant failed: inconsistent edge_has_new" - let assert_edge_has_new_consistent t = - if enabled then - StableMap.iter_with check_edge_has_new_entry t - t.old_successors_for_changed + 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 — take t directly *) + (* Callbacks for assert_deleted_nodes_closed *) let check_succ_in_deleted t succ = if StableSet.mem t.current succ then assert_ @@ -323,66 +319,72 @@ module Invariants = struct if enabled then StableSet.iter_with check_no_supported_deleted t t.deleted_nodes - let assert_current_minus_deleted t = - if enabled then ( - StableSet.copy ~dst:t.inv_scratch_a t.inv_pre_current; - StableSet.iter_with - (fun dst k -> StableSet.remove dst k) - t.inv_scratch_a 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_ - (StableSet.equal t.inv_scratch_a t.current) + (StableSet.equal expected t.current) "ReactiveFixpoint.apply invariant failed: current != pre_current minus \ deleted") (* Callbacks for assert_removal_output_matches / assert_final_fixpoint *) - let add_to_a_if_not_in_current t k = - if not (StableSet.mem t.current k) then StableSet.add t.inv_scratch_a k + 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_b_if_none dst k mv = + 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_a_if_not_in_pre t k = - if not (StableSet.mem t.inv_pre_current k) then - StableSet.add t.inv_scratch_a k - - let add_to_b_if_some dst k mv = + 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 t = - if enabled then ( - StableSet.clear t.inv_scratch_a; - StableSet.iter_with add_to_a_if_not_in_current t t.deleted_nodes; - StableSet.clear t.inv_scratch_b; - StableWave.iter_with t.output_wave add_to_b_if_none t.inv_scratch_b; + 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_ - (StableSet.equal t.inv_scratch_a t.inv_scratch_b) + (StableSet.equal expected actual) "ReactiveFixpoint.apply invariant failed: removal output mismatch") - let assert_final_fixpoint_and_delta t = - if enabled then ( + 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_ (StableSet.equal t.metrics.scratch_reachable t.current) "ReactiveFixpoint.apply invariant failed: current is not a fixed-point \ closure"; (* Check adds: nodes in current but not in pre_current *) - StableSet.clear t.inv_scratch_a; - StableSet.iter_with add_to_a_if_not_in_pre t t.current; - StableSet.clear t.inv_scratch_b; - StableWave.iter_with t.output_wave add_to_b_if_some t.inv_scratch_b; - let adds_ok = StableSet.equal t.inv_scratch_a t.inv_scratch_b in + 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 t.inv_scratch_a; - StableSet.iter_with add_to_a_if_not_in_current t t.inv_pre_current; - StableSet.clear t.inv_scratch_b; - StableWave.iter_with t.output_wave add_to_b_if_none t.inv_scratch_b; - let removes_ok = StableSet.equal t.inv_scratch_a t.inv_scratch_b in + 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)" - (StableSet.cardinal t.inv_pre_current) + (StableSet.cardinal pre_current) (StableSet.cardinal t.current) (StableWave.count t.output_wave))) end @@ -410,9 +412,6 @@ let create ~max_nodes ~max_edges = expansion_queue = StableQueue.create (); added_roots_queue = StableQueue.create (); edge_change_queue = StableQueue.create (); - inv_pre_current = StableSet.create (); - inv_scratch_a = StableSet.create (); - inv_scratch_b = StableSet.create (); new_successors_for_changed = StableMap.create (); metrics = { @@ -445,9 +444,6 @@ let destroy t = StableQueue.destroy t.expansion_queue; StableQueue.destroy t.added_roots_queue; StableQueue.destroy t.edge_change_queue; - StableSet.destroy t.inv_pre_current; - StableSet.destroy t.inv_scratch_a; - StableSet.destroy t.inv_scratch_b; StableSet.destroy t.metrics.scratch_reachable; StableWave.destroy t.output_wave let output_wave t = t.output_wave @@ -594,7 +590,18 @@ 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 = - if Invariants.enabled then StableSet.copy ~dst:t.inv_pre_current t.current; + (* Create scratch sets for invariant checks — only real when enabled *) + let pre_current = + if Invariants.enabled then Maybe.some (StableSet.create ()) else Maybe.none + in + let expected = + if Invariants.enabled then Maybe.some (StableSet.create ()) else Maybe.none + in + 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; @@ -618,7 +625,7 @@ let apply_list t ~roots ~edges = (fun t src mv -> scan_edge_entry t src (Maybe.of_stable mv)) t; - Invariants.assert_edge_has_new_consistent t; + Invariants.assert_edge_has_new_consistent expected t; (* Phase 2: delete BFS *) while not (StableQueue.is_empty t.delete_queue) do @@ -647,7 +654,7 @@ let apply_list t ~roots ~edges = StableMap.iter_with rebuild_edge_change_queue t t.new_successors_for_changed; StableSet.iter_with remove_from_current t t.deleted_nodes; - Invariants.assert_current_minus_deleted t; + Invariants.assert_current_minus_deleted ~pre_current ~expected t; (* Phase 4: rederive *) StableQueue.clear t.rederive_queue; @@ -706,8 +713,12 @@ let apply_list t ~roots ~edges = 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 t; - Invariants.assert_final_fixpoint_and_delta t; + 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 = diff --git a/analysis/reactive/src/StableMap.ml b/analysis/reactive/src/StableMap.ml index 96d908b67ef..945019acceb 100644 --- a/analysis/reactive/src/StableMap.ml +++ b/analysis/reactive/src/StableMap.ml @@ -169,5 +169,14 @@ let iter_with f arg t = 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 index 10eba293d7b..6227aaca497 100644 --- a/analysis/reactive/src/StableMap.mli +++ b/analysis/reactive/src/StableMap.mli @@ -17,6 +17,13 @@ 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/StableSet.ml b/analysis/reactive/src/StableSet.ml index f5ac1d5bff8..f9df875071b 100644 --- a/analysis/reactive/src/StableSet.ml +++ b/analysis/reactive/src/StableSet.ml @@ -138,6 +138,14 @@ let iter_with (type a k) (f : a -> k Stable.t -> unit) (arg : a) (t : k t) = 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 diff --git a/analysis/reactive/src/StableSet.mli b/analysis/reactive/src/StableSet.mli index 08049bcf327..8053022e670 100644 --- a/analysis/reactive/src/StableSet.mli +++ b/analysis/reactive/src/StableSet.mli @@ -27,6 +27,9 @@ val mem : 'a t -> 'a Stable.t -> bool 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. *) From c3002dea7a066c48b0fdd5aaff6c54420b3a3e3b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 10:49:25 +0100 Subject: [PATCH 52/54] test: detect server crashes in reactive server test Add a health check after each send_request to verify the server process is still alive, and fail immediately with the server log if it crashed. Co-Authored-By: Claude Opus 4.6 --- .../tests-reanalyze/deadcode/test-reactive-server.sh | 7 +++++++ 1 file changed, 7 insertions(+) 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 78ca46a877d..015d878cb21 100755 --- a/tests/analysis_tests/tests-reanalyze/deadcode/test-reactive-server.sh +++ b/tests/analysis_tests/tests-reanalyze/deadcode/test-reactive-server.sh @@ -263,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 From f97c9ec258bac7601f414d09025f6505dc44e08d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 11:57:26 +0100 Subject: [PATCH 53/54] analysis/reactive: fix StableQueue.resize and promote values before storing in C memory StableQueue.resize: add missing Block2.resize before blit (the old code tried to blit new_cap elements into a block of old_cap capacity) and reset head/tail to linearized positions after the copy. ReactiveFileCollection.process_files_batch: accumulate changes in an OCaml list first, then Gc.full_major() to promote all values to the major heap, then push to the C-allocated scratch_wave. This ensures the GC-invisible C pointers target stable major-heap addresses. Uses Stable.of_value (not unsafe_of_value) as a double-check that values are indeed promoted. Co-Authored-By: Claude Opus 4.6 --- .../reactive/src/ReactiveFileCollection.ml | 19 +++++++++++++++---- analysis/reactive/src/StableQueue.ml | 3 +++ 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/analysis/reactive/src/ReactiveFileCollection.ml b/analysis/reactive/src/ReactiveFileCollection.ml index c4a7388f077..4dbd4bb7a25 100644 --- a/analysis/reactive/src/ReactiveFileCollection.ml +++ b/analysis/reactive/src/ReactiveFileCollection.ml @@ -68,6 +68,10 @@ let process_files t paths = let process_files_batch t paths = 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 @@ -77,12 +81,19 @@ let process_files_batch t paths = 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); - StableWave.push t.scratch_wave - (Stable.unsafe_of_value path) - (Stable.unsafe_of_value (Maybe.some value)); + changes := (path, value) :: !changes; incr count) paths; - if !count > 0 then t.emit t.scratch_wave; + 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 *) diff --git a/analysis/reactive/src/StableQueue.ml b/analysis/reactive/src/StableQueue.ml index 461b53fe528..0954b70ef33 100644 --- a/analysis/reactive/src/StableQueue.ml +++ b/analysis/reactive/src/StableQueue.ml @@ -39,7 +39,10 @@ let resize (type a) (t : a t) new_cap = 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 = From 5ca43b98beab9bc609180a66fc0c2da83e9fe59a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 9 Mar 2026 12:08:08 +0100 Subject: [PATCH 54/54] analysis/reactive: use Maybe instead of option for file_data in reactive pipeline Zero-allocation change: ReactiveAnalysis.to_file_data_collection now returns file_data Maybe.t instead of file_data option, and ReactiveMerge.create consumes it using Maybe.of_stable/is_none/unsafe_get instead of option pattern matching. Co-Authored-By: Claude Opus 4.6 --- analysis/reanalyze/src/ReactiveAnalysis.ml | 10 ++- analysis/reanalyze/src/ReactiveMerge.ml | 86 +++++++++++++--------- analysis/reanalyze/src/ReactiveMerge.mli | 2 +- 3 files changed, 57 insertions(+), 41 deletions(-) diff --git a/analysis/reanalyze/src/ReactiveAnalysis.ml b/analysis/reanalyze/src/ReactiveAnalysis.ml index f2a4b399997..622715ad08f 100644 --- a/analysis/reanalyze/src/ReactiveAnalysis.ml +++ b/analysis/reanalyze/src/ReactiveAnalysis.ml @@ -133,17 +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 = + (string, DceFileProcessing.file_data Maybe.t) Reactive.t = Reactive.FlatMap.create ~name:"file_data_collection" (ReactiveFileCollection.to_collection collection) ~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; _} -> - StableWave.push wave path (Stable.unsafe_of_value (Some data)) - | _ -> StableWave.push wave path (Stable.unsafe_of_value None)) + 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/ReactiveMerge.ml b/analysis/reanalyze/src/ReactiveMerge.ml index b4e15905455..6474f907a2b 100644 --- a/analysis/reanalyze/src/ReactiveMerge.ml +++ b/analysis/reanalyze/src/ReactiveMerge.ml @@ -21,16 +21,18 @@ 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.create ~name:"decls" source - ~f:(fun _path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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) @@ -41,11 +43,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Annotations: (pos, annotated_as) with last-write-wins *) let annotations = Reactive.FlatMap.create ~name:"annotations" source - ~f:(fun _path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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 |> List.iter (fun (k, v) -> @@ -57,11 +61,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Value refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let value_refs_from = Reactive.FlatMap.create ~name:"value_refs_from" source - ~f:(fun _path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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 |> List.iter (fun (k, v) -> @@ -76,11 +82,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Type refs_from: (posFrom, PosSet of targets) with PosSet.union merge *) let type_refs_from = Reactive.FlatMap.create ~name:"type_refs_from" source - ~f:(fun _path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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 |> List.iter (fun (k, v) -> @@ -95,11 +103,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Cross-file items: (path, CrossFileItems.t) with merge by concatenation *) let cross_file_items = Reactive.FlatMap.create ~name:"cross_file_items" source - ~f:(fun path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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 @@ -120,11 +130,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* File deps map: (from_file, FileSet of to_files) with FileSet.union merge *) let file_deps_map = Reactive.FlatMap.create ~name:"file_deps_map" source - ~f:(fun _path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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) @@ -138,11 +150,13 @@ let create (source : (string, DceFileProcessing.file_data option) Reactive.t) : (* Files set: (source_path, ()) - just track which source files exist *) let files = Reactive.FlatMap.create ~name:"files" source - ~f:(fun _cmt_path file_data_opt wave -> - let file_data_opt = Stable.to_linear_value file_data_opt in - match file_data_opt with - | None -> () - | Some file_data -> + ~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 diff --git a/analysis/reanalyze/src/ReactiveMerge.mli b/analysis/reanalyze/src/ReactiveMerge.mli index 181c37a6953..e0a3b563e9d 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. *)