simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fixed-arity protocol dispatch shims

Browse source 
defprotocol emitted one variadic (fn [this & rest] (protocol-dispatch P m this
(list->cseq rest))) per method, so every protocol call — even a no-extra-arg one
like (area s) — consed a rest list, wrapped it in a cseq, var-deref'd
protocol-dispatch, and jolt-invoke'd it (consing again). On mono-dispatch that was
2.07GB of allocation, ~65% of the benchmark.

Emit one fixed-arity clause per declared arglist instead. The 1/2/3-param arities
call positional protocol-dispatch{1,2,3}, which resolve the impl (by record tag,
reify method, or host-tag extension — factored into protocol-resolve) and apply it
directly; no rest-list, no seq round-trip. The dispatchN entry points are in the
native-op table so the shim calls bind straight to the records.ss procedures
rather than var-deref. 4+ params fall back to the variadic protocol-dispatch.

mono-dispatch 1.5s/2.07GB -> 0.69s/280MB; dispatch 26x -> 12.2x, mono-dispatch
111x -> 51x vs JVM. 5 new corpus rows pin multi-arity methods, host-type args,
and protocol-method-as-value against JVM Clojure.
This commit is contained in:
Yogthos 2026-06-26 01:54:05 -04:00
parent 8bea1abe12
commit 75c16d4626
6 changed files with 663 additions and 625 deletions
Download patch file Download diff file Expand all files Collapse all files

61
host/chez/records.ss
View file

@ -453,32 +453,42 @@
(hashtable-set! ti proto-name (make-hashtable string-hash string=?))))
jolt-nil)
;; protocol-dispatch: look up the impl by the value's type tag (record) or host
;; candidates, invoke it; reified objects carry instance-local methods.
;; protocol-resolve: the impl procedure for obj — by record type tag, a reify's
;; instance-local method, or the protocol's extended impls over obj's host tags.
;; Raises if none implements the method. The dispatchN entry points apply it
;; directly so a protocol call doesn't cons a rest-list (the impl fn is always a
;; procedure, registered by register-(inline-)method/extend).
(define (protocol-resolve proto-name method-name obj)
(cond
((and (jrec? obj) (find-protocol-method (jrec-tag obj) proto-name method-name)))
((reified-methods obj)
=> (lambda (rm)
(or (hashtable-ref rm method-name #f)
;; not implemented on the reify — fall back to the protocol's
;; extended impls over the reify's host tags (e.g. an Object/default
;; extension). malli reifies some protocols and leans on the default.
(let loop ((tags (value-host-tags obj)))
(cond ((null? tags) (error #f (string-append "No reified method " method-name)))
((find-protocol-method (car tags) proto-name method-name))
(else (loop (cdr tags))))))))
(else
(let loop ((tags (value-host-tags obj)))
(cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name)))
((find-protocol-method (car tags) proto-name method-name))
(else (loop (cdr tags))))))))
;; Fixed-arity entry points the protocol-method shims call: no rest-list, no seq
;; round-trip — apply the resolved impl directly. defprotocol emits one clause per
;; declared arity that calls the matching dispatchN.
(define (protocol-dispatch1 proto-name method-name obj)
((protocol-resolve proto-name method-name obj) obj))
(define (protocol-dispatch2 proto-name method-name obj a)
((protocol-resolve proto-name method-name obj) obj a))
(define (protocol-dispatch3 proto-name method-name obj a b)
((protocol-resolve proto-name method-name obj) obj a b))
;; the variadic fallback (a declared arity of 4+ args) takes a seqable rest.
(define (protocol-dispatch proto-name method-name obj rest-args)
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(cond
((and (jrec? obj) (find-protocol-method (jrec-tag obj) proto-name method-name))
=> (lambda (f) (apply jolt-invoke f obj rest)))
((reified-methods obj)
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
(if f (apply jolt-invoke f obj rest)
;; not implemented on the reify — fall back to the
;; protocol's extended impls over the reify's host tags
;; (e.g. an Object/default extension). malli reifies some
;; protocols and relies on a protocol's default for the
;; rest.
(let loop ((tags (value-host-tags obj)))
(cond ((null? tags) (error #f (string-append "No reified method " method-name)))
((find-protocol-method (car tags) proto-name method-name)
=> (lambda (g) (apply jolt-invoke g obj rest)))
(else (loop (cdr tags)))))))))
(else
(let loop ((tags (value-host-tags obj)))
(cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name)))
((find-protocol-method (car tags) proto-name method-name)
=> (lambda (f) (apply jolt-invoke f obj rest)))
(else (loop (cdr tags)))))))))
(apply (protocol-resolve proto-name method-name obj) obj rest)))
;; dot-dispatch fallback used by emit for (.method record args): find the method
;; in ANY protocol the record's type implements.
@ -690,6 +700,9 @@
(def-var! "clojure.core" "register-inline-protocol!" register-inline-protocol!)
(def-var! "jolt.host" "set-field!" jolt-set-field!)
(def-var! "clojure.core" "protocol-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest)))
(def-var! "clojure.core" "protocol-dispatch1" (lambda (pn mn obj) (protocol-dispatch1 pn mn obj)))
(def-var! "clojure.core" "protocol-dispatch2" (lambda (pn mn obj a) (protocol-dispatch2 pn mn obj a)))
(def-var! "clojure.core" "protocol-dispatch3" (lambda (pn mn obj a b) (protocol-dispatch3 pn mn obj a b)))
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
(def-var! "clojure.core" "extenders" extenders)
(def-var! "clojure.core" "make-reified" (lambda (mm . rest) (apply make-reified mm rest)))

520
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

668
host/chez/seed/prelude.ss
View file

File diff suppressed because one or more lines are too long

27
jolt-core/clojure/core/30-macros.clj
View file

@ -432,13 +432,28 @@
;; register method var-keys for devirtualization; the inference
;; reads this (via infer-unit!) to resolve a protocol call on a known record
(register-protocol-methods! ~(name pname) [~@(map (fn [s] (name (first s))) sigs)])
;; one fn clause per declared arity. The protocol/method NAMES pass as
;; strings so the body compiles as a plain invoke (not symbol-as-var). The
;; common 1/2/3-param arities call positional protocol-dispatchN, which
;; applies the impl directly — no rest-list cons; 4+ params fall back to the
;; variadic protocol-dispatch with a vector of the extra args.
~@(map (fn [sig]
`(def ~(first sig)
;; protocol-dispatch is a fn (clojure.core); pass the protocol /
;; method NAMES as strings (not the symbols) so it compiles as a
;; plain invoke rather than evaluating the symbols as vars.
(fn* [this# & rest#]
(protocol-dispatch ~(name pname) ~(name (first sig)) this# rest#))))
(let [pn (name pname)
mn (name (first sig))
arglists (filter vector? (rest sig))
clause (fn [argv]
(let [ps (mapv (fn [_] (fresh-sym)) argv)
n (count ps)
obj (first ps)]
(cond
(= n 1) (list ps (list 'protocol-dispatch1 pn mn obj))
(= n 2) (list ps (list 'protocol-dispatch2 pn mn obj (nth ps 1)))
(= n 3) (list ps (list 'protocol-dispatch3 pn mn obj (nth ps 1) (nth ps 2)))
:else (list ps (list 'protocol-dispatch pn mn obj (vec (rest ps)))))))]
(if (seq arglists)
`(def ~(first sig) (fn* ~@(map clause arglists)))
`(def ~(first sig)
(fn* [this# & rest#] (protocol-dispatch ~pn ~mn this# rest#))))))
sigs))))
;; Member threading: (.. x f g) => (. (. x f) g); a parenthesized member

7
jolt-core/jolt/backend_scheme.clj
View file

@ -35,7 +35,11 @@
"keys" "jolt-keys" "vals" "jolt-vals"
"even?" "jolt-even?" "odd?" "jolt-odd?" "pos?" "jolt-pos?" "neg?" "jolt-neg?"
"zero?" "jolt-zero?" "identity" "jolt-identity" "nil?" "jolt-nil?" "some?" "jolt-some?"
"ex-info" "jolt-ex-info"})
"ex-info" "jolt-ex-info"
;; positional protocol-method dispatch (defprotocol-emitted shims) — bind
;; directly to the records.ss entry points so a protocol call doesn't var-deref.
"protocol-dispatch1" "protocol-dispatch1" "protocol-dispatch2" "protocol-dispatch2"
"protocol-dispatch3" "protocol-dispatch3"})
;; Value-position resolution for a clojure.core ref passed AS A VALUE (to map /
;; filter / reduce / apply). Arithmetic is the exception — Scheme's +/-/*// return
@ -57,6 +61,7 @@
"reverse" #(= % 1) "last" #(= % 1) "keys" #(= % 1) "vals" #(= % 1)
"even?" #(= % 1) "odd?" #(= % 1) "pos?" #(= % 1) "neg?" #(= % 1)
"zero?" #(= % 1) "identity" #(= % 1) "nil?" #(= % 1) "some?" #(= % 1)
"protocol-dispatch1" #(= % 3) "protocol-dispatch2" #(= % 4) "protocol-dispatch3" #(= % 5)
"cons" #(= % 2) "filter" #(= % 2) "remove" #(= % 2) "into" #(= % 2)
"take" #(= % 2) "drop" #(= % 2) "map" #(>= % 2) "apply" #(>= % 2)
"reduce" #(or (= % 2) (= % 3)) "range" #(and (>= % 0) (<= % 3))

5
test/chez/corpus.edn
View file

@ -3206,4 +3206,9 @@
{:suite "records / representation" :label "record as a map key" :expected ":v" :actual "(do (defrecord R [a]) (get {(->R 1) :v} (->R 1)))"}
{:suite "records / representation" :label "records dedup in a set by value" :expected "2" :actual "(do (defrecord R [a]) (count (into #{} [(->R 1) (->R 1) (->R 2)])))"}
{:suite "records / representation" :label "nested record field reads" :expected "[2 1]" :actual "(do (defrecord N [l r v]) (let [t (->N (->N nil nil 1) nil 2)] [(:v t) (:v (:l t))]))"}
{:suite "protocols / arity dispatch" :label "multi-arity protocol method on a record" :expected "[\"0:9\" \"1:9::a\" \"2:9::a::b\"]" :actual "(do (defprotocol P (m [this] [this x] [this x y])) (defrecord R [v] P (m [this] (str \"0:\" v)) (m [this x] (str \"1:\" v \":\" x)) (m [this x y] (str \"2:\" v \":\" x \":\" y))) [(m (->R 9)) (m (->R 9) :a) (m (->R 9) :a :b)])"}
{:suite "protocols / arity dispatch" :label "two-arg protocol method" :expected "30" :actual "(do (defprotocol P (addp [this x y])) (defrecord R [n] P (addp [_ x y] (+ n (+ x y)))) (addp (->R 10) 7 13))"}
{:suite "protocols / arity dispatch" :label "protocol method extended to a host type with an arg" :expected "\"S:hi:5\"" :actual "(do (defprotocol Q (mq [this a])) (extend-protocol Q java.lang.String (mq [this a] (str \"S:\" this \":\" a))) (mq \"hi\" 5))"}
{:suite "protocols / arity dispatch" :label "protocol method used as a value" :expected "[1 2]" :actual "(do (defprotocol Z (z [this])) (defrecord ZR [v] Z (z [_] v)) (mapv z [(->ZR 1) (->ZR 2)]))"}
{:suite "protocols / arity dispatch" :label "no-extra-arg method dispatches by type" :expected "[16 25]" :actual "(do (defprotocol Sh (ar [s])) (defrecord Sq [x] Sh (ar [_] (* x x))) (defrecord Sq2 [y] Sh (ar [_] (* y y))) [(ar (->Sq 4)) (ar (->Sq2 5))])"}
]