Devirt: cache the resolved impl in a per-site cell (inline cache) (#237)

A devirtualized protocol call resolved its impl with devirt-resolve on EVERY call
— but the tag/proto/method are compile-time constants, so the resolved fn is a
runtime constant (closed world). That per-call find-protocol-method (three
hashtable lookups) was the cost: on mono-dispatch, dispatch was ~75% of the time
(ablation: same arithmetic direct-call 166ms vs dispatch 673ms).

Resolve once. When emitting a direct-link def, each devirt site gets a fresh cache
cell, bound to #f in a let wrapping the def (so it persists across calls and is
shared by every invocation); the site resolves into it on first use ((or cell
(let ((_f (devirt-resolve ..))) (set! cell _f) _f))) and reuses it after — the
inline cache the JVM gets for free. First call still passes the real receiver, so
the Object/host-tag fallback (devirt-resolve) is unchanged.

mono-dispatch 673ms -> 214ms (~3.15x), 47.5x -> ~15x JVM, near the 166ms
direct-call floor. run-devirt.ss gains the cached-path checks (cell present, 1st
call caches + 2nd reuses, both == dispatch). make test / shakesmoke green, selfhost
holds, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>

host/chez/run-devirt.ss

@@ -77,6 +77,28 @@
 (let ((e (devirt-emit "user.Plain" "pl")))
   (check "devirt Object-default == dispatch" (run-emit e) (evals "(area pl)")))  ; :obj-default
 
+;; in a direct-link build a devirt site caches the resolved impl in a per-site cell
+;; (resolved once, reused) instead of resolving per call. Annotate the (area x) in a
+;; def body and emit the top form; the result must carry the cell and still be right.
+(let* ((set-direct-link! (var-deref "jolt.backend-scheme" "set-direct-link!"))
+       (emit-top-form    (var-deref "jolt.backend-scheme" "emit-top-form"))
+       (dn (analyze (make-analyze-ctx "user") (jolt-ce-read "(def usearea (fn [x] (area x)))")))
+       (ar0 (jolt-nth (jolt-get (jolt-get dn (kw "init")) (kw "arities")) 0))
+       (inv (jolt-get ar0 (kw "body")))
+       (inv2 (jolt-assoc inv (kw "devirt-type") "user.Circle" (kw "devirt-proto") "Shape" (kw "devirt-method") "area"))
+       (dn2 (jolt-assoc dn (kw "init")
+                        (jolt-assoc (jolt-get dn (kw "init")) (kw "arities")
+                                    (jolt-vector (jolt-assoc ar0 (kw "body") inv2))))))
+  (set-direct-link! #t)
+  (let ((e (emit-top-form dn2)))
+    (set-direct-link! #f)
+    (check "devirt in a def caches in a per-site cell" (has-sub? e "_dvc$") #t)
+    (check "cached cell still resolves the impl" (has-sub? e "devirt-resolve") #t)
+    ;; eval the def, then call it: caches on first call, reuses after — still 7.
+    (run-emit e)
+    (check "cached devirt == dispatch (1st call)" (jolt-invoke (var-deref "user" "usearea") (var-deref "user" "c")) 7)
+    (check "cached devirt == dispatch (2nd call, from cell)" (jolt-invoke (var-deref "user" "usearea") (var-deref "user" "c")) 7)))
+
 (if (= fails 0)
     (begin (printf "devirt gate: ~a/~a passed\n" total total) (exit 0))
     (begin (printf "devirt gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

jolt-core/jolt/backend_scheme.clj

@@ -162,6 +162,15 @@
 (def ^:private gensym-counter (atom 0))
 (defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
 
+;; Per-site devirt cache cells collected while emitting one top-level def. A
+;; devirtualized call resolves a CONSTANT impl (static tag/proto/method), so it
+;; needs resolving once, not per call — the inline cache the JVM gets for free. When
+;; a def init is being emitted this holds an atom; each devirt site appends a fresh
+;; cell name (bound to #f in a let wrapping the def, so it persists across calls and
+;; is shared by every invocation), and the site resolves into it on first use. nil
+;; outside a def (a devirt there falls back to a per-call resolve).
+(def ^:private devirt-cells (atom nil))
+
 ;; Scheme syntactic keywords. A jolt local with one of these names would, when
 ;; emitted verbatim, shadow the Scheme form in operator position (a local named
 ;; `if` would turn the special form (if …) the back end emits into a call), so
@@ -517,11 +526,21 @@
       ;; The receiver is bound once — it feeds both the resolve and the application.
       (:devirt-type node)
       (order-args (fn [as]
-                    (let [r (fresh-label "_r$")]
-                      (str "(let* ((" r " " (first as) ")) "
-                           "((devirt-resolve " (chez-str-lit (:devirt-type node)) " "
-                           (chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
-                           " " r ") " (str/join " " (cons r (rest as))) "))"))))
+                    (let [r (fresh-label "_r$")
+                          dv (str "(devirt-resolve " (chez-str-lit (:devirt-type node)) " "
+                                  (chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
+                                  " " r ")")
+                          cells @devirt-cells
+                          ;; cache the resolved impl in a per-site cell when inside a
+                          ;; def (resolved once on first call, then reused); else
+                          ;; resolve per call.
+                          resolver (if cells
+                                     (let [c (fresh-label "_dvc$")]
+                                       (swap! cells conj c)
+                                       (str "(or " c " (let ((_f " dv ")) (set! " c " _f) _f))"))
+                                     dv)]
+                      (str "(let* ((" r " " (first as) ")) ("
+                           resolver " " (str/join " " (cons r (rest as))) "))"))))
       ;; hint-directed fast arithmetic: jolt.passes.numeric proved every operand a
       ;; flonum (^double) or fixnum (^long), so emit the Chez fl*/fx* op.
       (:num-kind node) (emit-numeric (:num-kind node) (:name fnode) args order-args)
@@ -755,7 +774,15 @@
       ;; register before emitting the init so a self-referential body direct-links.
       (swap! direct-link-defined conj (dl-fqn ns nm))
       (when fn? (swap! direct-link-fns conj (dl-fqn ns nm)))
-      (let [init (emit (:init node))]
+      (let [cells (atom [])
+            _ (reset! devirt-cells cells)
+            raw (emit (:init node))
+            _ (reset! devirt-cells nil)
+            ;; wrap the init so each devirt site's cache cell persists across calls,
+            ;; shared by every invocation of this def.
+            init (if (seq @cells)
+                   (str "(let (" (str/join " " (map (fn [c] (str "(" c " #f)")) @cells)) ") " raw ")")
+                   raw)]
         (if (jmeta-nonempty? (:meta node))
           (str "(begin (define " b " " init ") (def-var-with-meta! "
                (chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) ")" (or reg "") ")")