Skip to content

Commit 8d619b3

Browse files
tiensonqintiensonqin
committed
Support upstream persistent set storage semantics
1 parent 571c38a commit 8d619b3

10 files changed

Lines changed: 436 additions & 30 deletions

‎.github/workflows/ci.yml‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,24 @@ jobs:
3434
with:
3535
node-version: "22"
3636

37+
- name: Set up browser for JS memory tests
38+
run: |
39+
browser=""
40+
for candidate in google-chrome google-chrome-stable chromium chromium-browser; do
41+
if command -v "$candidate" >/dev/null 2>&1; then
42+
browser="$(command -v "$candidate")"
43+
break
44+
fi
45+
done
46+
47+
if [ -z "$browser" ]; then
48+
echo "Chrome/Chromium is required for browser memory tests" >&2
49+
exit 1
50+
fi
51+
52+
echo "CHROME_BIN=$browser" >> "$GITHUB_ENV"
53+
"$browser" --version
54+
3755
- name: Install OCaml dependencies
3856
run: opam install . --deps-only --with-test -y
3957

@@ -49,5 +67,8 @@ jobs:
4967
UPSTREAM_TEST_DIFF_STRICT: "1"
5068
run: bash script/diff_upstream_tests.sh
5169

70+
- name: Check browser memory test CI wiring
71+
run: bash script/check_ci_browser_memory_test.sh
72+
5273
- name: Run tests
5374
run: opam exec -- dune runtest

‎docs/upstream-differences.md‎

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -94,8 +94,9 @@ OCaml uses several representations:
9494
- `Leaf of 'a list`
9595
- `Branch of 'a list * string list`
9696

97-
OCaml supports configurable `branching_factor`, validated at construction and
98-
restore time. The default is 32.
97+
OCaml supports configurable `branching_factor` and `ref_type`, validated at
98+
construction and restore time. The default branching factor is 32 and the
99+
default ref type is `Soft`.
99100

100101
## Public API Differences
101102

@@ -317,14 +318,17 @@ Upstream ClojureScript reports:
317318

318319
In the inspected ClojureScript file, `max-len` is fixed at 32.
319320

320-
OCaml exposes only:
321+
OCaml exposes:
321322

322323
```ocaml
323-
type settings = { branching_factor : int }
324+
type ref_type = Strong | Soft | Weak
325+
type settings = { branching_factor : int; ref_type : ref_type }
324326
```
325327

326-
and allows any value >= 2. Local tests cover custom branching factors. This is an
327-
OCaml extension relative to the ClojureScript implementation.
328+
and allows any branching factor >= 2. `Strong` keeps restored nodes cached in
329+
memory. `Soft` and `Weak` allow restored nodes to be released and fetched again;
330+
`Soft` is intentionally implemented with the same reclaimable behavior as
331+
`Weak`, because OCaml does not expose JVM soft-reference pressure heuristics.
328332

329333
## Test Coverage Differences
330334

‎lib/persistent_sorted_set.ml‎

Lines changed: 61 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
type 'a comparator = 'a -> 'a -> int
2-
type settings = { branching_factor : int }
2+
type ref_type = Strong | Soft | Weak
3+
type settings = { branching_factor : int; ref_type : ref_type }
34
type 'a stored_node = Leaf of 'a list | Branch of 'a list * string list
45

56
type 'a storage = {
@@ -53,7 +54,7 @@ let normalize_cmp cmp left right =
5354
match cmp left right with n when n < 0 -> -1 | 0 -> 0 | _ -> 1
5455

5556
let default_cmp left right = Stdlib.compare left right
56-
let default_settings = { branching_factor = 32 }
57+
let default_settings = { branching_factor = 32; ref_type = Soft }
5758

5859
let validate_settings settings =
5960
if settings.branching_factor < 2 then
@@ -62,7 +63,64 @@ let validate_settings settings =
6263

6364
let settings set = set.set_settings
6465

66+
let cache_storage settings storage =
67+
let remember cache address node =
68+
let slot = Weak.create 1 in
69+
Weak.set slot 0 (Some node);
70+
Hashtbl.replace cache address slot
71+
in
72+
match settings.ref_type with
73+
| Strong ->
74+
let cache = Hashtbl.create 128 in
75+
{
76+
store_node =
77+
(fun node ->
78+
let address = storage.store_node node in
79+
Hashtbl.replace cache address node;
80+
address);
81+
restore_node =
82+
(fun address ->
83+
match Hashtbl.find_opt cache address with
84+
| Some node -> Some node
85+
| None ->
86+
(match storage.restore_node address with
87+
| Some node ->
88+
Hashtbl.replace cache address node;
89+
Some node
90+
| None -> None));
91+
accessed = storage.accessed;
92+
}
93+
| Soft | Weak ->
94+
let cache = Hashtbl.create 128 in
95+
{
96+
store_node =
97+
(fun node ->
98+
let address = storage.store_node node in
99+
remember cache address node;
100+
address);
101+
restore_node =
102+
(fun address ->
103+
match Hashtbl.find_opt cache address with
104+
| Some slot -> (
105+
match Weak.get slot 0 with
106+
| Some node -> Some node
107+
| None -> (
108+
match storage.restore_node address with
109+
| Some node ->
110+
remember cache address node;
111+
Some node
112+
| None -> None))
113+
| None -> (
114+
match storage.restore_node address with
115+
| Some node ->
116+
remember cache address node;
117+
Some node
118+
| None -> None));
119+
accessed = storage.accessed;
120+
}
121+
65122
let empty_with_cmp ?storage settings cmp =
123+
let storage = Option.map (cache_storage settings) storage in
66124
{
67125
cmp;
68126
set_settings = settings;
@@ -1893,7 +1951,7 @@ let restore ?(cmp = default_cmp) ?(settings = default_settings) storage address
18931951
{
18941952
cmp = normalize_cmp cmp;
18951953
set_settings = settings;
1896-
set_storage = Some storage;
1954+
set_storage = Some (cache_storage settings storage);
18971955
data = Deferred { address };
18981956
count_cache = None;
18991957
}

‎lib/persistent_sorted_set.mli‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
type 'a comparator = 'a -> 'a -> int
2-
type settings = { branching_factor : int }
2+
type ref_type = Strong | Soft | Weak
3+
type settings = { branching_factor : int; ref_type : ref_type }
34
type 'a stored_node = Leaf of 'a list | Branch of 'a list * string list
45

56
type 'a storage = {

‎script/check_ci_browser_memory_test.sh‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
#!/usr/bin/env bash
2+
set -euo pipefail
3+
4+
repo_root="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)"
5+
workflow="$repo_root/.github/workflows/ci.yml"
6+
7+
if [ ! -f "$workflow" ]; then
8+
echo "CI workflow not found: .github/workflows/ci.yml" >&2
9+
exit 1
10+
fi
11+
12+
if ! grep -q 'CHROME_BIN=' "$workflow"; then
13+
echo "CI must export CHROME_BIN for browser memory tests" >&2
14+
exit 1
15+
fi
16+
17+
if ! grep -q 'run_browser_memory_test.js' "$repo_root/test/dune"; then
18+
echo "dune runtest must include the browser memory test runner" >&2
19+
exit 1
20+
fi
21+
22+
if ! grep -q -- '--expose-gc' "$repo_root/test/dune"; then
23+
echo "JS memory tests must run with GC exposed" >&2
24+
exit 1
25+
fi

‎test/dune‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,25 @@
1212
(modes js)
1313
(libraries persistent_sorted_set))
1414

15+
(executable
16+
(name js_memory_test)
17+
(modes js)
18+
(libraries persistent_sorted_set js_of_ocaml))
19+
1520
(rule
1621
(alias runtest)
1722
(deps js_smoke.bc.js)
1823
(action
1924
(run node %{dep:js_smoke.bc.js})))
25+
26+
(rule
27+
(alias runtest)
28+
(deps js_memory_test.bc.js)
29+
(action
30+
(run node --expose-gc %{dep:js_memory_test.bc.js})))
31+
32+
(rule
33+
(alias runtest)
34+
(deps js_memory_test.bc.js run_browser_memory_test.js)
35+
(action
36+
(run node %{dep:run_browser_memory_test.js} %{dep:js_memory_test.bc.js})))

‎test/js_memory_test.ml‎

Lines changed: 96 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,96 @@
1+
open Persistent_sorted_set
2+
open Js_of_ocaml
3+
4+
let set_result result =
5+
ignore
6+
(Js.Unsafe.fun_call
7+
(Js.Unsafe.js_expr
8+
{|
9+
(function(result) {
10+
globalThis.__PSS_MEMORY_TEST_RESULT = result;
11+
if (typeof document !== "undefined" && document.body) {
12+
document.body.setAttribute("data-pss-memory-result", result);
13+
document.body.textContent = result;
14+
}
15+
})
16+
|})
17+
[| Js.Unsafe.inject (Js.string result) |])
18+
19+
let failf fmt =
20+
Printf.ksprintf
21+
(fun message ->
22+
set_result ("fail: " ^ message);
23+
failwith message)
24+
fmt
25+
26+
let irange from_ to_ =
27+
let rec loop acc current =
28+
if current < from_ then acc else loop (current :: acc) (current - 1)
29+
in
30+
loop [] to_
31+
32+
let copy_stored_node = function
33+
| Leaf values -> Leaf values
34+
| Branch (keys, child_addresses) -> Branch (keys, child_addresses)
35+
36+
let set_timeout f milliseconds =
37+
ignore
38+
(Js.Unsafe.fun_call
39+
(Js.Unsafe.js_expr "setTimeout")
40+
[| Js.Unsafe.inject (Js.wrap_callback f)
41+
; Js.Unsafe.inject (Js.number_of_float (float_of_int milliseconds))
42+
|])
43+
44+
let force_full_collection () =
45+
for _ = 1 to 5 do
46+
Gc.full_major ()
47+
done
48+
49+
let check ref_type label =
50+
let memory = Hashtbl.create 16 in
51+
let writes = ref 0 in
52+
let restored_slots = ref [] in
53+
let storage =
54+
{
55+
store_node =
56+
(fun node ->
57+
incr writes;
58+
let address = "node-" ^ string_of_int !writes in
59+
Hashtbl.replace memory address node;
60+
address);
61+
restore_node =
62+
(fun address ->
63+
match Hashtbl.find_opt memory address with
64+
| None -> None
65+
| Some stored ->
66+
let node = copy_stored_node stored in
67+
let slot = Weak.create 1 in
68+
Weak.set slot 0 (Some node);
69+
restored_slots := slot :: !restored_slots;
70+
Some node);
71+
accessed = (fun _ -> ());
72+
}
73+
in
74+
let settings = { branching_factor = 4; ref_type } in
75+
let root, _ = store (of_list_by ~storage ~settings ~cmp:compare (irange 0 15)) in
76+
let restored =
77+
match restore ~cmp:compare ~settings storage root with
78+
| Some restored -> restored
79+
| None -> failf "%s restore should find the stored root" label
80+
in
81+
if not (mem 15 restored) then
82+
failf "%s restored set should contain stored value" label;
83+
if !restored_slots = [] then
84+
failf "%s test should observe restored nodes" label;
85+
!restored_slots
86+
87+
let () =
88+
let soft_slots = check Soft "soft" in
89+
let weak_slots = check Weak "weak" in
90+
set_timeout
91+
(fun () ->
92+
force_full_collection ();
93+
if List.exists (fun slot -> Weak.check slot 0) (soft_slots @ weak_slots)
94+
then failf "soft/weak ref-types should release restored nodes after JS GC"
95+
else set_result "pass")
96+
0

‎test/js_smoke.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,11 @@ open Persistent_sorted_set
22

33
let () =
44
let set =
5-
of_list_by ~settings:{ branching_factor = 4 } ~cmp:compare [ 3; 1; 2 ]
5+
of_list_by ~settings:{ default_settings with branching_factor = 4 } ~cmp:compare [ 3; 1; 2 ]
66
in
77
if to_list set <> [ 1; 2; 3 ] then failwith "js smoke sorted order failed";
88
if slice ~from_:2 ~to_:3 set <> [ 2; 3 ] then failwith "js smoke slice failed";
9-
if settings set <> { branching_factor = 4 } then
9+
if settings set <> { default_settings with branching_factor = 4 } then
1010
failwith "js smoke settings failed";
1111
if to_list (of_sorted_array [| 1; 1; 2; 3 |]) <> [ 1; 2; 3 ] then
1212
failwith "js smoke sorted array failed"

0 commit comments

Comments
 (0)