Devirtualize monomorphic protocol calls (#227)

When the inference proves a protocol call's receiver is one record type, the
back end resolves the impl by that static tag (find-protocol-method) instead of
routing through the protocol var -> jolt-invoke -> protocol-resolve, which
re-derives the tag and walks the type table. Same table lookup, minus the
var-deref, the rest-cons, and the receiver-type computation.

Fires only on a monomorphic site: a megamorphic receiver joins to :any and
carries no :devirt-type, so it keeps ordinary dispatch (the dispatch bench is
unaffected). The annotation comes from the whole-program fixpoint typing a
reduce/HOF element or a ctor return as a specific record.

Modest on the dispatch benchmarks (~6% on mono-dispatch) — float boxing in the
reduce accumulator dominates there, a separate numeric lever — but it removes
the dispatch overhead wherever a typed receiver is known.

run-devirt.ss gate: emitted form uses find-protocol-method, and evaluating it
matches ordinary dispatch for an inline impl, an extend-type impl, and the
non-devirt path. make test / shakesmoke green, 0 new divergences.

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

Makefile

@@ -4,7 +4,7 @@
 # build step. `make test` is the full gate. `make remint` rebuilds the seed after a
 # source change.
 
-.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer wp directlink numeric inline shakesmoke remint
+.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer wp devirt directlink numeric inline shakesmoke remint
 
 # Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
 # on the same Chez that minted the seed.
@@ -15,7 +15,7 @@ test: selfhost ci
 # lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
 # different Chez version may emit byte-different (gensym/order) output, so the
 # byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
-ci: values corpus unit smoke buildsmoke sci ffi transient infer wp directlink numeric inline certify
+ci: values corpus unit smoke buildsmoke sci ffi transient infer wp devirt directlink numeric inline certify
 	@echo "OK: CI gates passed"
 
 # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@@ -67,6 +67,12 @@ infer:
 wp:
 	@chez --script host/chez/run-wp.ss
 
+# Protocol-call devirtualization: a monomorphic call resolves its impl by the
+# inferred record tag (find-protocol-method) instead of routing through the
+# protocol var; the result must match ordinary dispatch.
+devirt:
+	@chez --script host/chez/run-devirt.ss
+
 # Direct-linking emission: a closed-world build binds top-level app defs to jv$
 # Scheme bindings and routes app->app calls/refs to them, skipping var-deref +
 # jolt-invoke; ^:dynamic/^:redef and nested defs opt out.

host/chez/run-devirt.ss

@@ -0,0 +1,71 @@
+;; run-devirt.ss — protocol-call devirtualization gate (backend_scheme emit).
+;;
+;; The inference annotates a monomorphic protocol call with :devirt-type/-proto/
+;; -method (jolt.passes.types); the back end then resolves the impl by that static
+;; tag. This gate pins both halves: the emitted form uses find-protocol-method, and
+;; evaluating it returns the same value the ordinary dispatch would — for a record's
+;; inline impl, an extend-type impl, and across distinct receiver types.
+;;
+;;   chez --script host/chez/run-devirt.ss
+(import (chezscheme))
+(load "host/chez/rt.ss")
+(set-chez-ns! "clojure.core")
+(load "host/chez/seed/prelude.ss")
+(load "host/chez/post-prelude.ss")
+(set-chez-ns! "user")
+(load "host/chez/host-contract.ss")
+(load "host/chez/seed/image.ss")
+(load "host/chez/compile-eval.ss")
+
+(define analyze (var-deref "jolt.analyzer" "analyze"))
+(define emit    (var-deref "jolt.backend-scheme" "emit"))
+(define kw      (lambda (n) (keyword #f n)))
+
+(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
+;; define two record types implementing one protocol — Circle via an inline impl,
+;; Square via extend-type — plus instances to dispatch on.
+(evals "(defprotocol Shape (area [s]))")
+(evals "(defrecord Circle [r] Shape (area [s] (:r s)))")
+(evals "(defrecord Square [w])")
+(evals "(extend-type Square Shape (area [s] (* (:w s) (:w s))))")
+(evals "(def c (->Circle 7))")
+(evals "(def sq (->Square 5))")
+
+;; analyze (area RECV), annotate it as a devirt call on `type`, and emit. RECV is a
+;; var name (c/sq) the emitted code resolves at eval time.
+(define (devirt-emit type recv)
+  (let* ((ir (analyze (make-analyze-ctx "user") (jolt-ce-read (string-append "(area " recv ")"))))
+         (dv (jolt-assoc ir (kw "devirt-type") type (kw "devirt-proto") "Shape"
+                         (kw "devirt-method") "area")))
+    (emit dv)))
+
+(define fails 0) (define total 0)
+(define (check label actual expected)
+  (set! total (+ total 1))
+  (unless (equal? actual expected)
+    (set! fails (+ fails 1))
+    (printf "  FAIL ~a: got ~s expected ~s\n" label actual expected)))
+(define (has-sub? s sub)
+  (let ((n (string-length s)) (m (string-length sub)))
+    (let loop ((i 0)) (cond ((> (+ i m) n) #f)
+                            ((string=? (substring s i (+ i m)) sub) #t)
+                            (else (loop (+ i 1)))))))
+;; eval an emitted Scheme string in the loaded runtime (var-deref resolves c/sq).
+(define (run-emit scm) (eval (read (open-input-string scm)) (interaction-environment)))
+
+(let ((e (devirt-emit "user.Circle" "c")))
+  (check "emit uses find-protocol-method" (has-sub? e "find-protocol-method") #t)
+  (check "devirt inline impl == dispatch" (run-emit e) (evals "(area c)")))   ; 7
+
+(let ((e (devirt-emit "user.Square" "sq")))
+  (check "devirt extend-type impl == dispatch" (run-emit e) (evals "(area sq)")))  ; 25
+
+;; a normal (no devirt) call still goes through dispatch and agrees — the path the
+;; megamorphic / unknown-receiver site keeps.
+(let ((e (emit (analyze (make-analyze-ctx "user") (jolt-ce-read "(area c)")))))
+  (check "non-devirt path no find-protocol-method" (has-sub? e "find-protocol-method") #f)
+  (check "non-devirt still dispatches" (run-emit e) 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

@@ -498,6 +498,18 @@
                                (fn [[f & as]]
                                  (str "(jolt-invoke " f (if (seq as) (str " " (str/join " " as)) "") ")"))))]
     (cond
+      ;; devirtualized protocol call: the inference proved the receiver (arg 0) is
+      ;; one record type, so resolve the impl by that static tag instead of routing
+      ;; through the protocol var -> jolt-invoke -> protocol-resolve (which recomputes
+      ;; the tag and walks the type table). find-protocol-method does the same table
+      ;; lookup the dispatch would, but with no var-deref, no rest-cons, and no
+      ;; receiver-type computation. Fires only on a monomorphic site (a megamorphic
+      ;; receiver joins to :any and carries no :devirt-type).
+      (:devirt-type node)
+      (order-args (fn [as]
+                    (str "((find-protocol-method " (chez-str-lit (:devirt-type node)) " "
+                         (chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
+                         ") " (str/join " " 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)