Initial

.github/workflows/ci.yml

@@ -0,0 +1,19 @@
+name: ci
+
+on:
+  push:
+  pull_request:
+
+jobs:
+  test:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: 5.1.x
+      - run: opam install . --deps-only --with-test --with-doc
+      - run: opam install ocamlformat
+      - run: opam exec -- dune fmt --check
+      - run: opam exec -- dune build @install @runtest @doc
+      - run: opam lint graphis.opam

.gitignore

@@ -0,0 +1,30 @@
+# dune / opam build outputs
+/_build/
+/_opam/
+/.opam-switch/
+*.install
+
+# generated graph dumps
+*.dot
+*.svg
+*.sv
+!docs/
+!docs/readme-graph.dot
+!docs/readme-graph.svg
+
+# ocaml tooling
+.merlin
+.utop
+*.annot
+*.cmt
+*.cmti
+
+# coverage / profiling
+*.coverage
+*.prof
+
+# editor and local runtime state
+.direnv/
+.env
+*.swp
+*~

.ocamlformat

@@ -0,0 +1,2 @@
+profile = default
+margin = 80

README.md

@@ -0,0 +1,28 @@
+# graphis
+
+inspects OCaml heap values and lowers the reachable object graph to
+graphviz DOT
+
+![graphis heap graph](docs/readme-graph.svg)
+
+## api
+
+the capture context is the alias analysis boundary. values captured through the same context share one address table so repeated physical values lower to the same node and cycles terminate through the visited set
+
+```ocaml
+Graphis.context (fun ctx ->
+  let shared = [| "left"; "right" |] in
+  let root = shared, shared in
+  Graphis.print_dot Format.std_formatter
+    [ "root", Graphis.capture ctx root ])
+```
+
+the same graph can be written as DOT for graphviz
+
+```ocaml
+Graphis.context (fun ctx ->
+  let shared = [| "left"; "right" |] in
+  let root = shared, shared in
+  Graphis.write_dot "heap.dot"
+    [ "root", Graphis.capture ctx root ])
+```

bench/bench_graphis.ml

@@ -0,0 +1,53 @@
+let measure name make =
+  Gc.compact ();
+  let start = Unix.gettimeofday () in
+  let root = Graphis.repr (make ()) in
+  let elapsed = Unix.gettimeofday () -. start in
+  let blocks =
+    match root with
+    | Graphis.Immediate _ -> 0
+    | Pointer pointer ->
+        let count = ref 0 in
+        Graphis.Heap.walk (fun _ -> incr count) (Graphis.Heap.follow pointer);
+        !count
+  in
+  Printf.printf "%-12s %8d blocks %.6fs\n%!" name blocks elapsed
+
+type tree =
+  | Leaf of int
+  | Node of tree * tree
+
+let rec tree depth =
+  if depth = 0 then Leaf depth else Node (tree (depth - 1), tree (depth - 1))
+
+let list size = List.init size Fun.id
+
+let closure_chain size =
+  let rec loop index acc =
+    if index = size then acc else loop (index + 1) (fun x -> acc (x + index))
+  in
+  loop 0 Fun.id
+
+type node = {
+  value : int;
+  mutable next : node option;
+}
+
+let cycle size =
+  let first = { value = 0; next = None } in
+  let rec loop prev index =
+    if index = size then
+      prev.next <- Some first
+    else
+      let node = { value = index; next = None } in
+      prev.next <- Some node;
+      loop node (index + 1)
+  in
+  loop first 1;
+  first
+
+let () =
+  measure "list" (fun () -> list 10_000);
+  measure "tree" (fun () -> tree 12);
+  measure "closures" (fun () -> closure_chain 1_000);
+  measure "cycle" (fun () -> cycle 10_000)

bench/dune

@@ -0,0 +1,5 @@
+(executable
+ (name bench_graphis)
+ (flags
+  (:standard -w -69))
+ (libraries graphis unix))

docs/readme-graph.dot

@@ -0,0 +1,45 @@
+digraph graphis {
+graph [bgcolor="transparent"];
+edge [color="gray20"];
+node [color="gray20", fontcolor="gray20"];
+rankdir=TB;
+{ rank=source;
+root_0 [label="{ value:cycle | . }" shape="record" style="filled" fillcolor="khaki1"];
+root_1 [label="{ value:tree | . }" shape="record" style="filled" fillcolor="khaki1"];
+root_2 [label="{ value:float_array | . }" shape="record" style="filled" fillcolor="khaki1"];
+root_3 [label="{ value:array | . }" shape="record" style="filled" fillcolor="khaki1"];
+root_4 [label="{ value:list | . }" shape="record" style="filled" fillcolor="khaki1"];
+root_5 [label="{ value:float | . }" shape="record" style="filled" fillcolor="khaki1"];
+root_6 [label="{ value:int | 13 }" shape="record" style="filled" fillcolor="khaki1"];
+}
+root_0 -> g1_n12:head;
+root_1 -> g1_n10:head;
+root_2 -> g1_n9:head;
+root_3 -> g1_n5:head;
+root_4 -> g1_n2:head;
+root_5 -> g1_n1:head;
+g1_n12 [label="{ <head> tag:0 | <f0> 1 | <f1> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n12:f1 -> g1_n13:head;
+g1_n13 [label="{ <head> tag:0 | <f0> 2 | <f1> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n13:f1 -> g1_n14:head;
+g1_n14 [label="{ <head> tag:0 | <f0> 3 | <f1> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n14:f1 -> g1_n12:head;
+g1_n10 [label="{ <head> tag:1 | <f0> . | <f1> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n10:f0 -> g1_n11:head;
+g1_n10:f1 -> g1_n11:head;
+g1_n11 [label="{ <head> tag:0 | <f0> 7 }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n9 [label="{ <head> tag:254 | <f0> 1 | <f1> 2 | <f2> 3 }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n5 [label="{ <head> tag:0 | <f0> . | <f1> . | <f2> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n5:f0 -> g1_n6:head;
+g1_n5:f1 -> g1_n7:head;
+g1_n5:f2 -> g1_n8:head;
+g1_n8 [label="{ <head> tag:252 | <f0> string:c }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n7 [label="{ <head> tag:252 | <f0> string:b }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n6 [label="{ <head> tag:252 | <f0> string:a }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n2 [label="{ <head> tag:0 | <f0> 1 | <f1> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n2:f1 -> g1_n3:head;
+g1_n3 [label="{ <head> tag:0 | <f0> 2 | <f1> . }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n3:f1 -> g1_n4:head;
+g1_n4 [label="{ <head> tag:0 | <f0> 3 | <f1> 0 }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+g1_n1 [label="{ <head> tag:253 | <f0> 42 }" shape="record" style="filled,rounded" fillcolor="aliceblue"];
+}

docs/readme-graph.svg

@@ -0,0 +1,298 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<!-- Generated by graphviz version 14.1.5 (0)
+ -->
+<!-- Title: graphis Pages: 1 -->
+<svg width="851pt" height="423pt"
+ viewBox="0.00 0.00 851.00 423.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 419)">
+<title>graphis</title>
+<!-- root_0 -->
+<g id="node1" class="node">
+<title>root_0</title>
+<polygon fill="#fff68f" stroke="#333333" points="7.62,-364 7.62,-414.5 102.38,-414.5 102.38,-364 7.62,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="55" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:cycle</text>
+<polyline fill="none" stroke="#333333" points="7.62,-389.25 102.38,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="55" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n12 -->
+<g id="node8" class="node">
+<title>g1_n12</title>
+<path fill="aliceblue" stroke="#333333" d="M40,-238.62C40,-238.62 70,-238.62 70,-238.62 76,-238.62 82,-244.62 82,-250.62 82,-250.62 82,-302.38 82,-302.38 82,-308.38 76,-314.38 70,-314.38 70,-314.38 40,-314.38 40,-314.38 34,-314.38 28,-308.38 28,-302.38 28,-302.38 28,-250.62 28,-250.62 28,-244.62 34,-238.62 40,-238.62"/>
+<text xml:space="preserve" text-anchor="middle" x="54.88" y="-297.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="28,-289.12 81.75,-289.12"/>
+<text xml:space="preserve" text-anchor="middle" x="54.88" y="-271.82" font-family="Times,serif" font-size="14.00" fill="#333333">1</text>
+<polyline fill="none" stroke="#333333" points="28,-263.88 81.75,-263.88"/>
+<text xml:space="preserve" text-anchor="middle" x="54.88" y="-246.57" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- root_0&#45;&gt;g1_n12 -->
+<g id="edge1" class="edge">
+<title>root_0&#45;&gt;g1_n12:head</title>
+<path fill="none" stroke="#333333" d="M54.94,-363.63C54.91,-352.7 54.89,-339.42 54.88,-326.53"/>
+<polygon fill="#333333" stroke="#333333" points="58.38,-326.89 54.88,-316.89 51.38,-326.89 58.38,-326.89"/>
+</g>
+<!-- root_1 -->
+<g id="node2" class="node">
+<title>root_1</title>
+<polygon fill="#fff68f" stroke="#333333" points="120,-364 120,-414.5 208,-414.5 208,-364 120,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="164" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:tree</text>
+<polyline fill="none" stroke="#333333" points="120,-389.25 208,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="164" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n10 -->
+<g id="node9" class="node">
+<title>g1_n10</title>
+<path fill="aliceblue" stroke="#333333" d="M149,-238.62C149,-238.62 179,-238.62 179,-238.62 185,-238.62 191,-244.62 191,-250.62 191,-250.62 191,-302.38 191,-302.38 191,-308.38 185,-314.38 179,-314.38 179,-314.38 149,-314.38 149,-314.38 143,-314.38 137,-308.38 137,-302.38 137,-302.38 137,-250.62 137,-250.62 137,-244.62 143,-238.62 149,-238.62"/>
+<text xml:space="preserve" text-anchor="middle" x="163.88" y="-297.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:1</text>
+<polyline fill="none" stroke="#333333" points="137,-289.12 190.75,-289.12"/>
+<text xml:space="preserve" text-anchor="middle" x="163.88" y="-271.82" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+<polyline fill="none" stroke="#333333" points="137,-263.88 190.75,-263.88"/>
+<text xml:space="preserve" text-anchor="middle" x="163.88" y="-246.57" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- root_1&#45;&gt;g1_n10 -->
+<g id="edge2" class="edge">
+<title>root_1&#45;&gt;g1_n10:head</title>
+<path fill="none" stroke="#333333" d="M163.94,-363.63C163.91,-352.7 163.89,-339.42 163.88,-326.53"/>
+<polygon fill="#333333" stroke="#333333" points="167.38,-326.89 163.88,-316.89 160.38,-326.89 167.38,-326.89"/>
+</g>
+<!-- root_2 -->
+<g id="node3" class="node">
+<title>root_2</title>
+<polygon fill="#fff68f" stroke="#333333" points="226.38,-364 226.38,-414.5 361.62,-414.5 361.62,-364 226.38,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="294" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:float_array</text>
+<polyline fill="none" stroke="#333333" points="226.38,-389.25 361.62,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="294" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n9 -->
+<g id="node10" class="node">
+<title>g1_n9</title>
+<path fill="aliceblue" stroke="#333333" d="M270.62,-226C270.62,-226 317.38,-226 317.38,-226 323.38,-226 329.38,-232 329.38,-238 329.38,-238 329.38,-315 329.38,-315 329.38,-321 323.38,-327 317.38,-327 317.38,-327 270.62,-327 270.62,-327 264.62,-327 258.62,-321 258.62,-315 258.62,-315 258.62,-238 258.62,-238 258.62,-232 264.62,-226 270.62,-226"/>
+<text xml:space="preserve" text-anchor="middle" x="294" y="-309.7" font-family="Times,serif" font-size="14.00" fill="#333333">tag:254</text>
+<polyline fill="none" stroke="#333333" points="258.62,-301.75 329.38,-301.75"/>
+<text xml:space="preserve" text-anchor="middle" x="294" y="-284.45" font-family="Times,serif" font-size="14.00" fill="#333333">1</text>
+<polyline fill="none" stroke="#333333" points="258.62,-276.5 329.38,-276.5"/>
+<text xml:space="preserve" text-anchor="middle" x="294" y="-259.2" font-family="Times,serif" font-size="14.00" fill="#333333">2</text>
+<polyline fill="none" stroke="#333333" points="258.62,-251.25 329.38,-251.25"/>
+<text xml:space="preserve" text-anchor="middle" x="294" y="-233.95" font-family="Times,serif" font-size="14.00" fill="#333333">3</text>
+</g>
+<!-- root_2&#45;&gt;g1_n9 -->
+<g id="edge3" class="edge">
+<title>root_2&#45;&gt;g1_n9:head</title>
+<path fill="none" stroke="#333333" d="M294,-363.72C294,-356.11 294,-347.48 294,-338.95"/>
+<polygon fill="#333333" stroke="#333333" points="297.5,-339.01 294,-329.01 290.5,-339.01 297.5,-339.01"/>
+</g>
+<!-- root_3 -->
+<g id="node4" class="node">
+<title>root_3</title>
+<polygon fill="#fff68f" stroke="#333333" points="379.5,-364 379.5,-414.5 476.5,-414.5 476.5,-364 379.5,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="428" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:array</text>
+<polyline fill="none" stroke="#333333" points="379.5,-389.25 476.5,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="428" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n5 -->
+<g id="node11" class="node">
+<title>g1_n5</title>
+<path fill="aliceblue" stroke="#333333" d="M413,-226C413,-226 443,-226 443,-226 449,-226 455,-232 455,-238 455,-238 455,-315 455,-315 455,-321 449,-327 443,-327 443,-327 413,-327 413,-327 407,-327 401,-321 401,-315 401,-315 401,-238 401,-238 401,-232 407,-226 413,-226"/>
+<text xml:space="preserve" text-anchor="middle" x="427.88" y="-309.7" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="401,-301.75 454.75,-301.75"/>
+<text xml:space="preserve" text-anchor="middle" x="427.88" y="-284.45" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+<polyline fill="none" stroke="#333333" points="401,-276.5 454.75,-276.5"/>
+<text xml:space="preserve" text-anchor="middle" x="427.88" y="-259.2" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+<polyline fill="none" stroke="#333333" points="401,-251.25 454.75,-251.25"/>
+<text xml:space="preserve" text-anchor="middle" x="427.88" y="-233.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- root_3&#45;&gt;g1_n5 -->
+<g id="edge4" class="edge">
+<title>root_3&#45;&gt;g1_n5:head</title>
+<path fill="none" stroke="#333333" d="M427.93,-363.72C427.91,-356.11 427.89,-347.48 427.88,-338.95"/>
+<polygon fill="#333333" stroke="#333333" points="431.38,-339.01 427.88,-329.01 424.38,-339.02 431.38,-339.01"/>
+</g>
+<!-- root_4 -->
+<g id="node5" class="node">
+<title>root_4</title>
+<polygon fill="#fff68f" stroke="#333333" points="557.38,-364 557.38,-414.5 638.62,-414.5 638.62,-364 557.38,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="598" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:list</text>
+<polyline fill="none" stroke="#333333" points="557.38,-389.25 638.62,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="598" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n2 -->
+<g id="node12" class="node">
+<title>g1_n2</title>
+<path fill="aliceblue" stroke="#333333" d="M583,-238.62C583,-238.62 613,-238.62 613,-238.62 619,-238.62 625,-244.62 625,-250.62 625,-250.62 625,-302.38 625,-302.38 625,-308.38 619,-314.38 613,-314.38 613,-314.38 583,-314.38 583,-314.38 577,-314.38 571,-308.38 571,-302.38 571,-302.38 571,-250.62 571,-250.62 571,-244.62 577,-238.62 583,-238.62"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-297.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="571,-289.12 624.75,-289.12"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-271.82" font-family="Times,serif" font-size="14.00" fill="#333333">1</text>
+<polyline fill="none" stroke="#333333" points="571,-263.88 624.75,-263.88"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-246.57" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- root_4&#45;&gt;g1_n2 -->
+<g id="edge5" class="edge">
+<title>root_4&#45;&gt;g1_n2:head</title>
+<path fill="none" stroke="#333333" d="M597.94,-363.63C597.91,-352.7 597.89,-339.42 597.88,-326.53"/>
+<polygon fill="#333333" stroke="#333333" points="601.38,-326.89 597.88,-316.89 594.38,-326.89 601.38,-326.89"/>
+</g>
+<!-- root_5 -->
+<g id="node6" class="node">
+<title>root_5</title>
+<polygon fill="#fff68f" stroke="#333333" points="656.88,-364 656.88,-414.5 747.12,-414.5 747.12,-364 656.88,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="702" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:float</text>
+<polyline fill="none" stroke="#333333" points="656.88,-389.25 747.12,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="702" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n1 -->
+<g id="node13" class="node">
+<title>g1_n1</title>
+<path fill="aliceblue" stroke="#333333" d="M678.62,-251.25C678.62,-251.25 725.38,-251.25 725.38,-251.25 731.38,-251.25 737.38,-257.25 737.38,-263.25 737.38,-263.25 737.38,-289.75 737.38,-289.75 737.38,-295.75 731.38,-301.75 725.38,-301.75 725.38,-301.75 678.62,-301.75 678.62,-301.75 672.62,-301.75 666.62,-295.75 666.62,-289.75 666.62,-289.75 666.62,-263.25 666.62,-263.25 666.62,-257.25 672.62,-251.25 678.62,-251.25"/>
+<text xml:space="preserve" text-anchor="middle" x="702" y="-284.45" font-family="Times,serif" font-size="14.00" fill="#333333">tag:253</text>
+<polyline fill="none" stroke="#333333" points="666.62,-276.5 737.38,-276.5"/>
+<text xml:space="preserve" text-anchor="middle" x="702" y="-259.2" font-family="Times,serif" font-size="14.00" fill="#333333">42</text>
+</g>
+<!-- root_5&#45;&gt;g1_n1 -->
+<g id="edge6" class="edge">
+<title>root_5&#45;&gt;g1_n1:head</title>
+<path fill="none" stroke="#333333" d="M702,-363.56C702,-349.55 702,-331.39 702,-314.01"/>
+<polygon fill="#333333" stroke="#333333" points="705.5,-314.26 702,-304.26 698.5,-314.26 705.5,-314.26"/>
+</g>
+<!-- root_6 -->
+<g id="node7" class="node">
+<title>root_6</title>
+<polygon fill="#fff68f" stroke="#333333" points="764.88,-364 764.88,-414.5 843.12,-414.5 843.12,-364 764.88,-364"/>
+<text xml:space="preserve" text-anchor="middle" x="804" y="-397.2" font-family="Times,serif" font-size="14.00" fill="#333333">value:int</text>
+<polyline fill="none" stroke="#333333" points="764.88,-389.25 843.12,-389.25"/>
+<text xml:space="preserve" text-anchor="middle" x="804" y="-371.95" font-family="Times,serif" font-size="14.00" fill="#333333">13</text>
+</g>
+<!-- g1_n13 -->
+<g id="node14" class="node">
+<title>g1_n13</title>
+<path fill="aliceblue" stroke="#333333" d="M12,-113.25C12,-113.25 42,-113.25 42,-113.25 48,-113.25 54,-119.25 54,-125.25 54,-125.25 54,-177 54,-177 54,-183 48,-189 42,-189 42,-189 12,-189 12,-189 6,-189 0,-183 0,-177 0,-177 0,-125.25 0,-125.25 0,-119.25 6,-113.25 12,-113.25"/>
+<text xml:space="preserve" text-anchor="middle" x="26.88" y="-171.7" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="0,-163.75 53.75,-163.75"/>
+<text xml:space="preserve" text-anchor="middle" x="26.88" y="-146.45" font-family="Times,serif" font-size="14.00" fill="#333333">2</text>
+<polyline fill="none" stroke="#333333" points="0,-138.5 53.75,-138.5"/>
+<text xml:space="preserve" text-anchor="middle" x="26.88" y="-121.2" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n12&#45;&gt;g1_n13 -->
+<g id="edge7" class="edge">
+<title>g1_n12:f1&#45;&gt;g1_n13:head</title>
+<path fill="none" stroke="#333333" d="M54.88,-237.62C54.88,-217.33 36.03,-214.6 29.26,-200.61"/>
+<polygon fill="#333333" stroke="#333333" points="32.72,-200.02 27.19,-190.98 25.87,-201.49 32.72,-200.02"/>
+</g>
+<!-- g1_n11 -->
+<g id="node16" class="node">
+<title>g1_n11</title>
+<path fill="aliceblue" stroke="#333333" d="M149,-125.88C149,-125.88 179,-125.88 179,-125.88 185,-125.88 191,-131.88 191,-137.88 191,-137.88 191,-164.38 191,-164.38 191,-170.38 185,-176.38 179,-176.38 179,-176.38 149,-176.38 149,-176.38 143,-176.38 137,-170.38 137,-164.38 137,-164.38 137,-137.88 137,-137.88 137,-131.88 143,-125.88 149,-125.88"/>
+<text xml:space="preserve" text-anchor="middle" x="163.88" y="-159.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="137,-151.12 190.75,-151.12"/>
+<text xml:space="preserve" text-anchor="middle" x="163.88" y="-133.82" font-family="Times,serif" font-size="14.00" fill="#333333">7</text>
+</g>
+<!-- g1_n10&#45;&gt;g1_n11 -->
+<g id="edge10" class="edge">
+<title>g1_n10:f0&#45;&gt;g1_n11:head</title>
+<path fill="none" stroke="#333333" d="M191.75,-276.5C208.81,-276.5 194.49,-254.77 190.75,-238.12 185.21,-213.48 169.48,-208.15 165.05,-188.64"/>
+<polygon fill="#333333" stroke="#333333" points="168.55,-188.46 164.03,-178.88 161.59,-189.19 168.55,-188.46"/>
+</g>
+<!-- g1_n10&#45;&gt;g1_n11 -->
+<g id="edge11" class="edge">
+<title>g1_n10:f1&#45;&gt;g1_n11:head</title>
+<path fill="none" stroke="#333333" d="M163.88,-237.62C163.88,-215.03 163.88,-206.74 163.88,-188.61"/>
+<polygon fill="#333333" stroke="#333333" points="167.38,-188.89 163.88,-178.89 160.38,-188.89 167.38,-188.89"/>
+</g>
+<!-- g1_n6 -->
+<g id="node17" class="node">
+<title>g1_n6</title>
+<path fill="aliceblue" stroke="#333333" d="M314.25,-125.88C314.25,-125.88 361.75,-125.88 361.75,-125.88 367.75,-125.88 373.75,-131.88 373.75,-137.88 373.75,-137.88 373.75,-164.38 373.75,-164.38 373.75,-170.38 367.75,-176.38 361.75,-176.38 361.75,-176.38 314.25,-176.38 314.25,-176.38 308.25,-176.38 302.25,-170.38 302.25,-164.38 302.25,-164.38 302.25,-137.88 302.25,-137.88 302.25,-131.88 308.25,-125.88 314.25,-125.88"/>
+<text xml:space="preserve" text-anchor="middle" x="338" y="-159.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:252</text>
+<polyline fill="none" stroke="#333333" points="302.25,-151.12 373.75,-151.12"/>
+<text xml:space="preserve" text-anchor="middle" x="338" y="-133.82" font-family="Times,serif" font-size="14.00" fill="#333333">string:a</text>
+</g>
+<!-- g1_n5&#45;&gt;g1_n6 -->
+<g id="edge12" class="edge">
+<title>g1_n5:f0&#45;&gt;g1_n6:head</title>
+<path fill="none" stroke="#333333" d="M400,-289.12C394.17,-289.12 385.7,-204.76 378.92,-174.44"/>
+<polygon fill="#333333" stroke="#333333" points="382.19,-173.21 375.3,-165.16 375.67,-175.75 382.19,-173.21"/>
+</g>
+<!-- g1_n7 -->
+<g id="node18" class="node">
+<title>g1_n7</title>
+<path fill="aliceblue" stroke="#333333" d="M403.88,-125.88C403.88,-125.88 452.12,-125.88 452.12,-125.88 458.12,-125.88 464.12,-131.88 464.12,-137.88 464.12,-137.88 464.12,-164.38 464.12,-164.38 464.12,-170.38 458.12,-176.38 452.12,-176.38 452.12,-176.38 403.88,-176.38 403.88,-176.38 397.88,-176.38 391.88,-170.38 391.88,-164.38 391.88,-164.38 391.88,-137.88 391.88,-137.88 391.88,-131.88 397.88,-125.88 403.88,-125.88"/>
+<text xml:space="preserve" text-anchor="middle" x="428" y="-159.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:252</text>
+<polyline fill="none" stroke="#333333" points="391.88,-151.12 464.12,-151.12"/>
+<text xml:space="preserve" text-anchor="middle" x="428" y="-133.82" font-family="Times,serif" font-size="14.00" fill="#333333">string:b</text>
+</g>
+<!-- g1_n5&#45;&gt;g1_n7 -->
+<g id="edge13" class="edge">
+<title>g1_n5:f1&#45;&gt;g1_n7:head</title>
+<path fill="none" stroke="#333333" d="M455.75,-263.88C472.81,-263.88 459.25,-241.96 454.75,-225.5 449.46,-206.14 434.85,-202.62 429.77,-188.48"/>
+<polygon fill="#333333" stroke="#333333" points="433.27,-188.19 428.24,-178.87 426.35,-189.3 433.27,-188.19"/>
+</g>
+<!-- g1_n8 -->
+<g id="node19" class="node">
+<title>g1_n8</title>
+<path fill="aliceblue" stroke="#333333" d="M494.62,-125.88C494.62,-125.88 541.38,-125.88 541.38,-125.88 547.38,-125.88 553.38,-131.88 553.38,-137.88 553.38,-137.88 553.38,-164.38 553.38,-164.38 553.38,-170.38 547.38,-176.38 541.38,-176.38 541.38,-176.38 494.62,-176.38 494.62,-176.38 488.62,-176.38 482.62,-170.38 482.62,-164.38 482.62,-164.38 482.62,-137.88 482.62,-137.88 482.62,-131.88 488.62,-125.88 494.62,-125.88"/>
+<text xml:space="preserve" text-anchor="middle" x="518" y="-159.07" font-family="Times,serif" font-size="14.00" fill="#333333">tag:252</text>
+<polyline fill="none" stroke="#333333" points="482.62,-151.12 553.38,-151.12"/>
+<text xml:space="preserve" text-anchor="middle" x="518" y="-133.82" font-family="Times,serif" font-size="14.00" fill="#333333">string:c</text>
+</g>
+<!-- g1_n5&#45;&gt;g1_n8 -->
+<g id="edge14" class="edge">
+<title>g1_n5:f2&#45;&gt;g1_n8:head</title>
+<path fill="none" stroke="#333333" d="M455.75,-238.62C478.89,-238.62 465.49,-211.39 473,-189.5 474.96,-183.79 474.1,-177.35 474.26,-172.34"/>
+<polygon fill="#333333" stroke="#333333" points="476.79,-174.77 480.64,-164.9 471.47,-170.21 476.79,-174.77"/>
+</g>
+<!-- g1_n3 -->
+<g id="node20" class="node">
+<title>g1_n3</title>
+<path fill="aliceblue" stroke="#333333" d="M583,-113.25C583,-113.25 613,-113.25 613,-113.25 619,-113.25 625,-119.25 625,-125.25 625,-125.25 625,-177 625,-177 625,-183 619,-189 613,-189 613,-189 583,-189 583,-189 577,-189 571,-183 571,-177 571,-177 571,-125.25 571,-125.25 571,-119.25 577,-113.25 583,-113.25"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-171.7" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="571,-163.75 624.75,-163.75"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-146.45" font-family="Times,serif" font-size="14.00" fill="#333333">2</text>
+<polyline fill="none" stroke="#333333" points="571,-138.5 624.75,-138.5"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-121.2" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n2&#45;&gt;g1_n3 -->
+<g id="edge15" class="edge">
+<title>g1_n2:f1&#45;&gt;g1_n3:head</title>
+<path fill="none" stroke="#333333" d="M597.88,-237.62C597.88,-220.58 597.88,-213.72 597.88,-200.82"/>
+<polygon fill="#333333" stroke="#333333" points="601.38,-201.01 597.88,-191.01 594.38,-201.01 601.38,-201.01"/>
+</g>
+<!-- g1_n14 -->
+<g id="node15" class="node">
+<title>g1_n14</title>
+<path fill="aliceblue" stroke="#333333" d="M40,-0.5C40,-0.5 70,-0.5 70,-0.5 76,-0.5 82,-6.5 82,-12.5 82,-12.5 82,-64.25 82,-64.25 82,-70.25 76,-76.25 70,-76.25 70,-76.25 40,-76.25 40,-76.25 34,-76.25 28,-70.25 28,-64.25 28,-64.25 28,-12.5 28,-12.5 28,-6.5 34,-0.5 40,-0.5"/>
+<text xml:space="preserve" text-anchor="middle" x="54.88" y="-58.95" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="28,-51 81.75,-51"/>
+<text xml:space="preserve" text-anchor="middle" x="54.88" y="-33.7" font-family="Times,serif" font-size="14.00" fill="#333333">3</text>
+<polyline fill="none" stroke="#333333" points="28,-25.75 81.75,-25.75"/>
+<text xml:space="preserve" text-anchor="middle" x="54.88" y="-8.45" font-family="Times,serif" font-size="14.00" fill="#333333">.</text>
+</g>
+<!-- g1_n13&#45;&gt;g1_n14 -->
+<g id="edge8" class="edge">
+<title>g1_n13:f1&#45;&gt;g1_n14:head</title>
+<path fill="none" stroke="#333333" d="M26.88,-112.75C26.88,-97.23 43.29,-96.25 50.98,-87.55"/>
+<polygon fill="#333333" stroke="#333333" points="54.26,-88.77 54.36,-78.17 47.68,-86.39 54.26,-88.77"/>
+</g>
+<!-- g1_n14&#45;&gt;g1_n12 -->
+<g id="edge9" class="edge">
+<title>g1_n14:f1&#45;&gt;g1_n12:head</title>
+<path fill="none" stroke="#333333" d="M82.75,-13.12C111.69,-13.12 114.51,-248.13 91.23,-294.03"/>
+<polygon fill="#333333" stroke="#333333" points="88.91,-291.41 83.87,-300.73 93.62,-296.59 88.91,-291.41"/>
+</g>
+<!-- g1_n4 -->
+<g id="node21" class="node">
+<title>g1_n4</title>
+<path fill="aliceblue" stroke="#333333" d="M583,-0.5C583,-0.5 613,-0.5 613,-0.5 619,-0.5 625,-6.5 625,-12.5 625,-12.5 625,-64.25 625,-64.25 625,-70.25 619,-76.25 613,-76.25 613,-76.25 583,-76.25 583,-76.25 577,-76.25 571,-70.25 571,-64.25 571,-64.25 571,-12.5 571,-12.5 571,-6.5 577,-0.5 583,-0.5"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-58.95" font-family="Times,serif" font-size="14.00" fill="#333333">tag:0</text>
+<polyline fill="none" stroke="#333333" points="571,-51 624.75,-51"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-33.7" font-family="Times,serif" font-size="14.00" fill="#333333">3</text>
+<polyline fill="none" stroke="#333333" points="571,-25.75 624.75,-25.75"/>
+<text xml:space="preserve" text-anchor="middle" x="597.88" y="-8.45" font-family="Times,serif" font-size="14.00" fill="#333333">0</text>
+</g>
+<!-- g1_n3&#45;&gt;g1_n4 -->
+<g id="edge16" class="edge">
+<title>g1_n3:f1&#45;&gt;g1_n4:head</title>
+<path fill="none" stroke="#333333" d="M597.88,-112.75C597.88,-101.38 597.88,-96.07 597.88,-88.2"/>
+<polygon fill="#333333" stroke="#333333" points="601.38,-88.26 597.88,-78.26 594.38,-88.26 601.38,-88.26"/>
+</g>
+</g>
+</svg>

dune

@@ -0,0 +1 @@
+(dirs :standard \ _build)

dune-project

@@ -0,0 +1,16 @@
+(lang dune 3.11)
+
+(name graphis)
+(version 0.1.0)
+(license MIT)
+
+(implicit_transitive_deps false)
+
+(package
+ (name graphis)
+ (depends
+  (ocaml (>= 5.0))
+  dune
+  (odoc :with-doc))
+ (synopsis "inspect OCaml values as heap graphs")
+ (description "graphis inspects OCaml values, preserves sharing, and emits graphviz DOT heap graphs"))

examples/demo/demo.ml

@@ -0,0 +1,25 @@
+type tree =
+  | Leaf of int
+  | Node of tree * tree
+
+let int_value = 13
+let float_value = 42.0
+let list_value = [ 1; 2; 3 ]
+let array_value = [| "a"; "b"; "c" |]
+let float_array = [| 1.0; 2.0; 3.0 |]
+let shared = Leaf 7
+let tree = Node (shared, shared)
+let rec cycle = 1 :: 2 :: 3 :: cycle
+
+let () =
+  Graphis.context (fun ctx ->
+      Graphis.print_dot Format.std_formatter
+        [
+          "cycle", Graphis.capture ctx cycle;
+          "tree", Graphis.capture ctx tree;
+          "float_array", Graphis.capture ctx float_array;
+          "array", Graphis.capture ctx array_value;
+          "list", Graphis.capture ctx list_value;
+          "float", Graphis.capture ctx float_value;
+          "int", Graphis.capture ctx int_value;
+        ])

examples/demo/dune

@@ -0,0 +1,5 @@
+(executable
+ (name demo)
+ (flags
+  (:standard -w -30))
+ (libraries graphis))

examples/linked_list/dune

@@ -0,0 +1,5 @@
+(executable
+ (name example)
+ (flags
+  (:standard -w -30-69))
+ (libraries graphis))

examples/linked_list/example.ml

@@ -0,0 +1,22 @@
+type node = {
+  value : int;
+  mutable next : node option;
+}
+
+let node value = { value; next = None }
+
+let () =
+  let tail = node 30 in
+  let left = node 10 in
+  let right = node 20 in
+  left.next <- Some tail;
+  right.next <- Some tail;
+  tail.next <- Some left;
+
+  Graphis.context (fun ctx ->
+      Graphis.print_dot Format.std_formatter
+        [
+          "left_head", Graphis.capture ctx left;
+          "right_head", Graphis.capture ctx right;
+          "shared_tail", Graphis.capture ctx tail;
+        ])

graphis.opam

@@ -0,0 +1,16 @@
+opam-version: "2.0"
+synopsis: "inspect OCaml values as heap graphs"
+description:
+  "graphis inspects OCaml values, preserves sharing, and emits Graphviz DOT heap graphs"
+maintainer: ""
+authors: ""
+license: "MIT"
+depends: [
+  "ocaml" {>= "5.0"}
+  "dune"
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc}]
+]

src/dot.ml

@@ -0,0 +1,189 @@
+type config = {
+  external_color : string option;
+  block_color : string option;
+  root_color : string option;
+  outline_color : string;
+  background : string option;
+  direction : [ `Vertical | `Horizontal ];
+}
+
+let config
+    ?(external_color = Some "gray86")
+    ?(block_color = Some "aliceblue")
+    ?(root_color = Some "khaki1")
+    ?(outline_color = "gray20")
+    ?(background = None)
+    ?(direction = `Vertical)
+    () =
+  { external_color; block_color; root_color; outline_color; background; direction }
+
+let escape_label text =
+  let b = Buffer.create (String.length text + 8) in
+  String.iter
+    (function
+      | '"' -> Buffer.add_string b "\\\""
+      | '\\' -> Buffer.add_string b "\\\\"
+      | '{' -> Buffer.add_string b "\\{"
+      | '}' -> Buffer.add_string b "\\}"
+      | '|' -> Buffer.add_string b "\\|"
+      | '<' -> Buffer.add_string b "\\<"
+      | '>' -> Buffer.add_string b "\\>"
+      | '\n' -> Buffer.add_string b "\\n"
+      | c -> Buffer.add_char b c)
+    text;
+  Buffer.contents b
+
+let style color fmt extras =
+  let styles = match color with None -> extras | Some _ -> "filled" :: extras in
+  begin
+    match styles with
+    | [] -> ()
+    | _ -> Format.fprintf fmt " style=\"%s\"" (String.concat "," styles)
+  end;
+  match color with
+  | None -> ()
+  | Some color -> Format.fprintf fmt " fillcolor=\"%s\"" (escape_label color)
+
+let graph_prefix graph = Format.asprintf "g%d" (Heap.graph_id graph)
+let node_name graph addr = Format.asprintf "%s_n%d" (graph_prefix graph) (Heap.addr_int addr)
+let external_name graph value =
+  let raw = Format.asprintf "%nx" value in
+  let clean =
+    String.map
+      (function
+        | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c -> c
+        | '-' -> 'm'
+        | _ -> '_')
+      raw
+  in
+  Format.asprintf "%s_e%s" (graph_prefix graph) clean
+
+let root_name index = Format.asprintf "root_%d" index
+
+let node_port item =
+  match item.Heap.offset with
+  | 0 -> "head"
+  | offset -> Format.asprintf "f%d" (offset - 1)
+
+let direct_text = function
+  | Heap.Immediate i -> string_of_int i
+  | Heap.Pointer _ -> "."
+
+let slot_text = function
+  | Heap.Slot_int i -> string_of_int i
+  | Slot_ptr _ -> "."
+  | Slot_external _ -> "."
+  | Slot_float f -> Printf.sprintf "%g" f
+  | Slot_infix -> "infix"
+  | Slot_closure_info info ->
+      Printf.sprintf "arity:%d env:%d" info.arity info.env_start
+
+let payload_label = function
+  | Heap.Opaque -> "<f0> opaque"
+  | String_data text -> Format.asprintf "<f0> string:%s" (escape_label text)
+  | Float_data f -> Format.asprintf "<f0> %g" f
+  | Slots [||] -> ""
+  | Slots slots ->
+      Array.mapi
+        (fun i slot -> Format.asprintf "<f%d> %s" i (escape_label (slot_text slot)))
+        slots
+      |> Array.to_list
+      |> String.concat " | "
+
+let node_label item =
+  Format.asprintf "{ <head> tag:%d | %s }"
+    (Heap.tag_int item.Heap.node.tag)
+    (payload_label item.Heap.node.payload)
+
+let print_external config printed fmt graph value =
+  let name = external_name graph value in
+  if not (Hashtbl.mem printed name) then begin
+    Hashtbl.add printed name ();
+    Format.fprintf fmt "%s [label=\"{ <head> external | 0x%nx }\" shape=\"record\"%a];@\n"
+      name value (style config.external_color) [ "rounded" ]
+  end
+
+let print_edges config printed_external fmt item =
+  match item.Heap.node.payload with
+  | Opaque | String_data _ | Float_data _ -> ()
+  | Slots slots ->
+      Array.iteri
+        (fun index -> function
+          | Heap.Slot_ptr addr ->
+              let dst = Heap.follow_addr item.graph addr in
+              Format.fprintf fmt "%s:f%d -> %s:%s;@\n"
+                (node_name item.graph item.node.addr)
+                index
+                (node_name item.graph dst.node.addr)
+                (node_port dst)
+          | Slot_external value ->
+              print_external config printed_external fmt item.graph value;
+              Format.fprintf fmt "%s:f%d -> %s:head;@\n"
+                (node_name item.graph item.node.addr)
+                index
+                (external_name item.graph value)
+          | _ -> ())
+        slots
+
+let print_node config printed_nodes printed_external fmt item =
+  let name = node_name item.Heap.graph item.node.addr in
+  if not (Hashtbl.mem printed_nodes name) then begin
+    Hashtbl.add printed_nodes name ();
+    Format.fprintf fmt "%s [label=\"%s\" shape=\"record\"%a];@\n"
+      name
+      (node_label item)
+      (style config.block_color) [ "rounded" ];
+    print_edges config printed_external fmt item
+  end
+
+let print_root config fmt index (label, direct) =
+  Format.fprintf fmt "%s [label=\"{ value:%s | %s }\" shape=\"record\"%a];@\n"
+    (root_name index)
+    (escape_label label)
+    (escape_label (direct_text direct))
+    (style config.root_color) []
+
+let print_root_edge fmt index = function
+  | _, Heap.Immediate _ -> ()
+  | _, Pointer pointer ->
+      let item = Heap.follow pointer in
+      Format.fprintf fmt "%s -> %s:%s;@\n"
+        (root_name index)
+        (node_name pointer.graph item.node.addr)
+        (node_port item)
+
+let print ?(config = config ()) fmt roots =
+  let printed_nodes = Hashtbl.create 64 in
+  let printed_external = Hashtbl.create 32 in
+  Format.fprintf fmt "digraph graphis {@\n";
+  Format.fprintf fmt "graph [bgcolor=\"%s\"];@\n"
+    (match config.background with None -> "transparent" | Some c -> escape_label c);
+  Format.fprintf fmt "edge [color=\"%s\"];@\n" (escape_label config.outline_color);
+  Format.fprintf fmt "node [color=\"%s\", fontcolor=\"%s\"];@\n"
+    (escape_label config.outline_color)
+    (escape_label config.outline_color);
+  Format.fprintf fmt "rankdir=%s;@\n"
+    (match config.direction with `Vertical -> "TB" | `Horizontal -> "LR");
+  Format.fprintf fmt "{ rank=source;@\n";
+  List.iteri (print_root config fmt) roots;
+  Format.fprintf fmt "}@\n";
+  List.iteri (print_root_edge fmt) roots;
+  List.iter
+    (function
+      | _, Heap.Immediate _ -> ()
+      | _, Pointer pointer ->
+          Heap.walk
+            (print_node config printed_nodes printed_external fmt)
+            (Heap.follow pointer))
+    roots;
+  Format.fprintf fmt "}@."
+
+let to_file ?config path roots =
+  let flags = [ Unix.O_CREAT; Unix.O_EXCL; Unix.O_WRONLY ] in
+  let fd = Unix.openfile path flags 0o640 in
+  let channel = Unix.out_channel_of_descr fd in
+  Fun.protect
+    ~finally:(fun () -> close_out channel)
+    (fun () ->
+      let fmt = Format.formatter_of_out_channel channel in
+      print ?config fmt roots)

src/dot.mli

@@ -0,0 +1,16 @@
+(** Graphviz DOT lowering. *)
+
+type config
+
+val config :
+  ?external_color:string option ->
+  ?block_color:string option ->
+  ?root_color:string option ->
+  ?outline_color:string ->
+  ?background:string option ->
+  ?direction:[ `Vertical | `Horizontal ] ->
+  unit ->
+  config
+
+val print : ?config:config -> Format.formatter -> (string * Heap.direct) list -> unit
+val to_file : ?config:config -> string -> (string * Heap.direct) list -> unit

src/dune

@@ -0,0 +1,10 @@
+(library
+ (name graphis)
+ (public_name graphis)
+ (libraries unix)
+ (flags
+  (:standard -w -30))
+ (modules graphis heap dot))
+
+(documentation
+ (package graphis))

src/graphis.ml

@@ -0,0 +1,13 @@
+module Heap = Heap
+module Dot = Dot
+
+type context = Heap.context
+type direct = Heap.direct =
+  | Immediate of int
+  | Pointer of Heap.pointer
+
+let context = Heap.context
+let capture = Heap.capture
+let repr = Heap.repr
+let print_dot = Dot.print
+let write_dot = Dot.to_file

src/graphis.mli

@@ -0,0 +1,19 @@
+module Heap = Heap
+module Dot = Dot
+
+type context = Heap.context
+type direct = Heap.direct =
+  | Immediate of int
+  | Pointer of Heap.pointer
+
+val context : (context -> 'a) -> 'a
+val capture : context -> 'a -> direct
+val repr : 'a -> direct
+
+val print_dot :
+  ?config:Dot.config ->
+  Format.formatter ->
+  (string * direct) list ->
+  unit
+
+val write_dot : ?config:Dot.config -> string -> (string * direct) list -> unit

src/heap.ml

@@ -0,0 +1,290 @@
+type tag = int
+type addr = int
+
+type closure_info = {
+  arity : int;
+  env_start : int;
+}
+
+type graph = {
+  id : int;
+  mutable next_addr : int;
+  blocks : (addr, pointee) Hashtbl.t;
+}
+
+and pointer = {
+  graph : graph;
+  addr : addr;
+}
+
+and direct =
+  | Immediate of int
+  | Pointer of pointer
+
+and slot =
+  | Slot_int of int
+  | Slot_ptr of addr
+  | Slot_external of nativeint
+  | Slot_float of float
+  | Slot_infix
+  | Slot_closure_info of closure_info
+
+and payload =
+  | Opaque
+  | String_data of string
+  | Float_data of float
+  | Slots of slot array
+
+and node = {
+  addr : addr;
+  tag : tag;
+  payload : payload;
+}
+
+and pointee = {
+  graph : graph;
+  node : node;
+  offset : int;
+}
+
+type context = {
+  graph : graph;
+  mutable seen : (Obj.t * addr) list;
+}
+
+type lookup_error = Missing_addr of { graph_id : int; addr : addr }
+exception Lookup_error of lookup_error
+
+type validation_error =
+  | Missing_block of addr
+  | Node_addr_mismatch of { table_addr : addr; node_addr : addr }
+  | Dangling_slot of { from_addr : addr; slot : int; target_addr : addr }
+
+let graph_seq = ref 0
+
+let fresh_graph () =
+  incr graph_seq;
+  { id = !graph_seq; next_addr = 0; blocks = Hashtbl.create 64 }
+
+let fresh_addr graph =
+  graph.next_addr <- graph.next_addr + 1;
+  graph.next_addr
+
+let graph_id graph = graph.id
+let addr_int addr = addr
+let tag_int tag = tag
+
+let find_addr (graph : graph) addr =
+  match Hashtbl.find_opt graph.blocks addr with
+  | Some item -> Ok item
+  | None -> Error (Missing_addr { graph_id = graph.id; addr })
+
+let follow_addr (graph : graph) addr =
+  match find_addr graph addr with
+  | Ok item -> item
+  | Error error -> raise (Lookup_error error)
+
+let follow (pointer : pointer) = follow_addr pointer.graph pointer.addr
+
+let walk visit root =
+  let visited = Hashtbl.create 64 in
+  let pending = Stack.create () in
+  Stack.push root.node.addr pending;
+  while not (Stack.is_empty pending) do
+    let addr = Stack.pop pending in
+    if not (Hashtbl.mem visited addr) then begin
+      Hashtbl.add visited addr ();
+      let item = follow_addr root.graph addr in
+      visit item;
+      match item.node.payload with
+      | Opaque | String_data _ | Float_data _ -> ()
+      | Slots slots ->
+          Array.iter
+            (function
+              | Slot_ptr addr when not (Hashtbl.mem visited addr) ->
+                  Stack.push addr pending
+              | _ -> ())
+            slots
+    end
+  done
+
+let validate graph =
+  let errors = ref [] in
+  let require_block addr =
+    if not (Hashtbl.mem graph.blocks addr) then
+      errors := Missing_block addr :: !errors
+  in
+  Hashtbl.iter
+    (fun table_addr item ->
+      if item.offset = 0 && item.node.addr <> table_addr then
+        errors :=
+          Node_addr_mismatch { table_addr; node_addr = item.node.addr } :: !errors;
+      match item.node.payload with
+      | Opaque | String_data _ | Float_data _ -> ()
+      | Slots slots ->
+          Array.iteri
+            (fun slot -> function
+              | Slot_ptr target_addr ->
+                  if not (Hashtbl.mem graph.blocks target_addr) then
+                    errors :=
+                      Dangling_slot
+                        { from_addr = item.node.addr; slot; target_addr }
+                      :: !errors
+              | _ -> ())
+            slots)
+    graph.blocks;
+  for addr = 1 to graph.next_addr do
+    require_block addr
+  done;
+  match List.rev !errors with
+  | [] -> Ok ()
+  | errors -> Error errors
+
+let is_env_start info next size =
+  info.env_start = next
+  && next <= size
+  && ((info.arity = 1 && info.env_start = 2)
+     || (info.arity > 1 && info.env_start = 3))
+
+let closure_info block index =
+  let raw = Obj.field block index in
+  if not (Obj.is_int raw) then { arity = 0; env_start = max_int }
+  else
+    let packed : int = Obj.obj raw in
+    let arity = packed lsr (Sys.word_size - 9) in
+    let env_start = (packed lsl 8) lsr 8 in
+    { arity; env_start }
+
+let rec lower_block ctx addr value =
+  let tag = Obj.tag value in
+  if tag = Obj.infix_tag then
+    lower_infix ctx addr value
+  else
+    let payload, seen =
+      if tag = Obj.double_tag then
+        Float_data (Obj.obj value : float), ctx.seen
+      else if tag = Obj.string_tag then
+        String_data (Obj.obj value : string), ctx.seen
+      else if tag = Obj.double_array_tag then
+        let slots =
+          Array.init (Obj.size value) (fun index ->
+              Slot_float (Obj.double_field value index))
+        in
+        Slots slots, ctx.seen
+      else if tag = Obj.closure_tag then
+        lower_closure ctx value
+      else if tag < Obj.no_scan_tag then
+        let seen = ref ctx.seen in
+        let slots =
+          Array.init (Obj.size value) (fun index ->
+              let next, slot = lower_slot ctx !seen (Obj.field value index) in
+              seen := next;
+              slot)
+        in
+        Slots slots, !seen
+      else
+        Opaque, ctx.seen
+    in
+    let node = { addr; tag; payload } in
+    Hashtbl.replace ctx.graph.blocks addr { graph = ctx.graph; node; offset = 0 };
+    ctx.seen <- (value, addr) :: seen
+
+and lower_infix ctx addr value =
+  let offset = Obj.size value in
+  let bytes = offset * Sys.word_size / 8 in
+  let base = Obj.add_offset value Int32.(neg (of_int bytes)) in
+  let seen, direct = lower_direct ctx ctx.seen base in
+  ctx.seen <- seen;
+  match direct with
+  | Immediate _ -> assert false
+  | Pointer parent ->
+      let target = follow parent in
+      begin
+        match target.node.payload with
+        | Slots slots when offset > 0 && offset - 1 < Array.length slots ->
+            slots.(offset - 1) <- Slot_infix
+        | _ -> ()
+      end;
+      Hashtbl.replace ctx.graph.blocks addr
+        { graph = ctx.graph; node = target.node; offset };
+      ctx.seen <- (value, addr) :: ctx.seen
+
+and lower_closure ctx value =
+  match Sys.backend_type with
+  | Sys.Native | Sys.Bytecode ->
+      let size = Obj.size value in
+      let seen, slots = closure_entries ctx ctx.seen value size 0 [] in
+      Slots (Array.of_list (List.rev slots)), seen
+  | Sys.Other _ -> Opaque, ctx.seen
+
+and closure_entries ctx seen value size index acc =
+  if index >= size then
+    seen, acc
+  else
+    let index, acc =
+      if index = 0 then
+        index, acc
+      else
+        index + 1, Slot_infix :: acc
+    in
+    if index + 1 >= size then
+      seen, acc
+    else
+      let info = closure_info value (index + 1) in
+      let code = Slot_external (Obj.raw_field value index) in
+      let acc, next =
+        if info.arity = 1 || index + 2 >= size then
+          Slot_closure_info info :: code :: acc, index + 2
+        else
+          let curry = Slot_external (Obj.raw_field value (index + 2)) in
+          curry :: Slot_closure_info info :: code :: acc, index + 3
+      in
+      if is_env_start info next size then
+        closure_env ctx seen value size next acc
+      else
+        closure_entries ctx seen value size next acc
+
+and closure_env ctx seen value size index acc =
+  if index >= size then
+    seen, acc
+  else
+    let seen, slot = lower_slot ctx seen (Obj.field value index) in
+    closure_env ctx seen value size (index + 1) (slot :: acc)
+
+and lower_slot ctx seen value =
+  if Obj.is_int value then
+    seen, Slot_int (Obj.obj value : int)
+  else if Obj.tag value = Obj.out_of_heap_tag then
+    let raw : int = Obj.magic value in
+    seen, Slot_external Nativeint.(shift_left (of_int raw) 1)
+  else
+    match List.assq_opt value seen with
+    | Some addr -> seen, Slot_ptr addr
+    | None ->
+        let addr = fresh_addr ctx.graph in
+        ctx.seen <- (value, addr) :: seen;
+        lower_block ctx addr value;
+        ctx.seen, Slot_ptr addr
+
+and lower_direct ctx seen value =
+  if Obj.is_int value then
+    seen, Immediate (Obj.obj value : int)
+  else
+    match List.assq_opt value seen with
+    | Some addr -> seen, Pointer { graph = ctx.graph; addr }
+    | None ->
+        let addr = fresh_addr ctx.graph in
+        ctx.seen <- (value, addr) :: seen;
+        lower_block ctx addr value;
+        ctx.seen, Pointer { graph = ctx.graph; addr }
+
+let context f =
+  let ctx = { graph = fresh_graph (); seen = [] } in
+  f ctx
+
+let capture ctx value =
+  let seen, direct = lower_direct ctx ctx.seen (Obj.repr value) in
+  ctx.seen <- seen;
+  direct
+
+let repr value = context (fun ctx -> capture ctx value)

src/heap.mli

@@ -0,0 +1,80 @@
+(** this module is the unsafe boundary. it reads OCaml runtime values through
+    [Obj], preserves physical sharing and then  assigns deterministic graph-local
+    addresses to heap blocks. *)
+
+type tag = private int
+type addr = private int
+
+type closure_info = {
+  arity : int;
+  env_start : int;
+}
+
+type graph
+
+type pointer = private {
+  graph : graph;
+  addr : addr;
+}
+
+type direct =
+  | Immediate of int
+  | Pointer of pointer
+
+type slot =
+  | Slot_int of int
+  | Slot_ptr of addr
+  | Slot_external of nativeint
+  | Slot_float of float
+  | Slot_infix
+  | Slot_closure_info of closure_info
+
+type payload =
+  | Opaque
+  | String_data of string
+  | Float_data of float
+  | Slots of slot array
+
+type node = private {
+  addr : addr;
+  tag : tag;
+  payload : payload;
+}
+
+type pointee = private {
+  graph : graph;
+  node : node;
+  offset : int;
+}
+
+type lookup_error = Missing_addr of { graph_id : int; addr : addr }
+exception Lookup_error of lookup_error
+
+type validation_error =
+  | Missing_block of addr
+  | Node_addr_mismatch of { table_addr : addr; node_addr : addr }
+  | Dangling_slot of { from_addr : addr; slot : int; target_addr : addr }
+
+type context
+
+val context : (context -> 'a) -> 'a
+(** run a capture scope. values captured with the supplied context share one
+    graph, so physical sharing across roots is preserved. *)
+
+val capture : context -> 'a -> direct
+val repr : 'a -> direct
+
+val follow : pointer -> pointee
+val follow_addr : graph -> addr -> pointee
+(** [follow_addr graph addr] resolves [addr] or raises [Lookup_error]. *)
+
+val find_addr : graph -> addr -> (pointee, lookup_error) result
+val walk : (pointee -> unit) -> pointee -> unit
+(** depth-first traversal over blocks reachable from the supplied pointee.
+    each graph address is visited at most once. *)
+
+val validate : graph -> (unit, validation_error list) result
+
+val graph_id : graph -> int
+val addr_int : addr -> int
+val tag_int : tag -> int

test/dune

@@ -0,0 +1,5 @@
+(test
+ (name test_graphis)
+ (flags
+  (:standard -w -30))
+ (libraries graphis))

test/test_graphis.ml

@@ -0,0 +1,129 @@
+let assert_true message condition =
+  if not condition then failwith message
+
+let assert_equal_int message expected actual =
+  if expected <> actual then
+    failwith
+      (Printf.sprintf "%s: expected %d, got %d" message expected actual)
+
+let dot roots =
+  Format.asprintf "%a" (Graphis.print_dot ?config:None) roots
+
+let contains needle haystack =
+  let needle_len = String.length needle in
+  let haystack_len = String.length haystack in
+  let rec loop index =
+    index + needle_len <= haystack_len
+    && (String.sub haystack index needle_len = needle || loop (index + 1))
+  in
+  needle_len = 0 || loop 0
+
+let pointer message = function
+  | Graphis.Pointer pointer -> pointer
+  | Immediate _ -> failwith message
+
+let follow_direct message direct =
+  Graphis.Heap.follow (pointer message direct)
+
+let validate_direct direct =
+  let pointer = pointer "expected pointer root" direct in
+  match Graphis.Heap.validate pointer.graph with
+  | Ok () -> ()
+  | Error _ -> failwith "heap graph should validate"
+
+let reachable_count item =
+  let count = ref 0 in
+  Graphis.Heap.walk (fun _ -> incr count) item;
+  !count
+
+let slot_ptrs item =
+  match item.Graphis.Heap.node.payload with
+  | Slots slots ->
+      Array.to_list slots
+      |> List.filter_map (function
+           | Graphis.Heap.Slot_ptr addr -> Some addr
+           | _ -> None)
+  | _ -> []
+
+let test_immediate () =
+  match Graphis.repr 41 with
+  | Immediate 41 -> ()
+  | _ -> failwith "int should lower to immediate"
+
+let test_sharing () =
+  let pair =
+    Graphis.context (fun ctx ->
+        let shared = [ 1; 2 ] in
+        Graphis.capture ctx (shared, shared))
+  in
+  validate_direct pair;
+  let item = follow_direct "pair should be a pointer" pair in
+  match slot_ptrs item with
+  | left :: right :: _ ->
+      assert_true "shared pair should preserve physical aliasing" (left = right)
+  | _ -> failwith "pair should lower to pointer slots"
+
+let test_cycle () =
+  let root =
+    Graphis.context (fun ctx ->
+        let rec xs = 1 :: 2 :: xs in
+        Graphis.capture ctx xs)
+  in
+  validate_direct root;
+  let item = follow_direct "cycle should be a pointer" root in
+  assert_equal_int "cycle should contain two cons cells" 2 (reachable_count item)
+
+let test_strings_and_floats () =
+  let root =
+    Graphis.context (fun ctx ->
+        Graphis.capture ctx ("alpha", [| 1.0; 2.0 |]))
+  in
+  validate_direct root;
+  let output = dot [ "mixed", root ] in
+  assert_true "string payload should be visible" (contains "alpha" output);
+  assert_true "float array payload should be visible" (contains "1" output)
+
+let test_opaque_block () =
+  let root = Graphis.repr stdin in
+  validate_direct root;
+  let item = follow_direct "channel should be a pointer" root in
+  assert_true "channel should lower to an opaque runtime block"
+    (match item.node.payload with Graphis.Heap.Opaque -> true | _ -> false)
+
+let test_closure () =
+  let root =
+    Graphis.context (fun ctx ->
+        let base = 3 in
+        Graphis.capture ctx (fun x -> x + base))
+  in
+  validate_direct root;
+  let output = dot [ "fn", root ] in
+  assert_true "closure should expose closure metadata"
+    (contains "arity:" output || contains "opaque" output)
+
+let test_dot_escaping_and_config () =
+  let root = Graphis.repr ("a\"b\\c{d}|<e>\nf") in
+  let config =
+    Graphis.Dot.config ~background:(Some "white") ~direction:`Horizontal ()
+  in
+  let output = Format.asprintf "%a" (Graphis.print_dot ~config) [ "s", root ] in
+  assert_true "DOT should escape quotes" (contains "\\\"" output);
+  assert_true "DOT should escape backslashes" (contains "\\\\" output);
+  assert_true "DOT should escape record separators" (contains "\\|" output);
+  assert_true "DOT should apply horizontal rankdir" (contains "rankdir=LR" output);
+  assert_true "DOT should apply background" (contains "bgcolor=\"white\"" output)
+
+let test_root_ordering () =
+  let output = dot [ "a", Graphis.repr 1; "b", Graphis.repr 2 ] in
+  assert_true "first root should be emitted" (contains "root_0" output);
+  assert_true "second root should be emitted" (contains "root_1" output)
+
+let () =
+  test_immediate ();
+  test_sharing ();
+  test_cycle ();
+  test_strings_and_floats ();
+  test_opaque_block ();
+  test_closure ();
+  test_dot_escaping_and_config ();
+  test_root_ordering ()